home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / INTERPRT.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-11-11  |  97.4 KB  |  3,447 lines
  1. ;* INTERPRT.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        The main VM interpreter loop                *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 11 Feb 86:    Replaced support for even? and odd? to reduce code    *
  18. ;*    size and to update error messages.                *
  19. ;*        Improved error handling for divide, quotient, and    *
  20. ;*    remainder.                            *
  21. ;*        Fixed divide by zero error in Remainder function    *
  22. ;* - 7 Jan 87:    added random I/O - dbs                    *
  23. ;* - 10 Feb 87:    added new opcode (186) for read-line - tc        *
  24. ;* - 8 Mar 87:    variable-length opcodes - rb                *
  25. ;* - 16 Mar 87:    Added dos-err entry point to detect Dos I/O errors.    *
  26. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  27. ;*                                    *
  28. ;*                    ``In nomine omnipotentii dei''    *
  29. ;************************************************************************
  30. IDEAL
  31. %PAGESIZE    60, 132
  32. MODEL    small
  33. LOCALS    @@
  34.  
  35.     INCLUDE    "scheme.ash"
  36.  
  37. SEGMENT    NILPAGE    PARA    PUBLIC    'FAR_DATA'
  38. ENDS    NILPAGE
  39.  
  40. DATASEG
  41.                     ; Primary opcode lookup table
  42. op_table DW    copy            ; 000- load    dest,src
  43.     DW    ld_const        ; 001- ld-const    dest,constant-number (byte)
  44.     DW    ld_imm            ; 002- ld-imm    dest,immed-value (byte)
  45.     DW    ld_nil            ; 003- ld-nil    dest
  46.     DW    ld_local        ; 004- ld-local    dest,entry-number (byte)
  47.     DW    ld_lex            ; 005- ld-lex    dest,entry-no,delta-level
  48.     DW    ld_env            ; 006- ld-env    R(dest),C(sym)
  49.     DW    ld_globl        ; 007- ld-global dest,constant-number (byte)
  50.  
  51.     DW    ld_fluid        ; 008- ld-fluid    dest,constant-number (byte)
  52.     DW    ld_off_s        ; 009- ld-vec-s    vect,offset (byte)
  53.     DW    ld_off_l        ; 010- ld-vec-l    vect,offset (word)
  54.     DW    ld_off_r        ; 011- ld-vec-r    vect,offset (reg)
  55.     DW    st_local        ; 012- st-local    src,entry-number (byte)
  56.     DW    st_lex            ; 013- st-lex    src,entry-no,delta-level
  57.     DW    st_env            ; 014- st-env    R(val),C(sym)
  58.     DW    st_globl        ; 015- st-global src,constant-number (byte)
  59.  
  60.     DW    st_fluid        ; 016- st-fluid    src,constant-number (byte)
  61.     DW    st_off_s        ; 017- st-vec-s    vect,offset (byte),src
  62.     DW    st_off_l        ; 018- st-vec-l    vect,offset (word),src
  63.     DW    st_off_r        ; 019- st-vec-r    vect,offset (reg),src
  64.     DW    set_car            ; 020- set-car!    dest,src
  65.     DW    set_cdr            ; 021- set-cdr!    dest,src
  66.     DW    recompil        ; 022- (unused) formerly set-ref!
  67.     DW    recompil        ; 023- (unused) formerly swap-ref!
  68.  
  69.     DW    spop            ; 024- pop    dest
  70.     DW    spush            ; 025- push    src
  71.     DW    sdrop            ; 026- drop    count (unsigned byte)
  72.     DW    ld_globr        ; 027- ld-global-r dest,sym
  73.     DW    recompil        ; 028- (unused- formerly push-heap)
  74.     DW    bind_fl            ; 029- bind-fl    const,src
  75.     DW    unbind_f        ; 030- unbind_fl count (byte)
  76.     DW    define            ; 031- define!    src,const
  77.  
  78.     DW    jmp_shrt        ; 032- jmp_s    label (byte)
  79.     DW    jmp_long        ; 033- jmp_l    label (word)
  80.     DW    j_nil_s            ; 034- jnil_s    reg,label (byte)
  81.     DW    j_nil_l            ; 035- jnil_l    reg,label (word)
  82.     DW    j_nnil_s        ; 036- jnnil_s    reg,label (byte)
  83.     DW    j_nnil_l        ; 037- jnnil_l    reg,label (word)
  84.     DW    j_atm_s            ; 038- jatom_s    reg,label (byte)
  85.     DW    j_atm_l            ; 039- jatom_l    reg,label (word)
  86.  
  87.     DW    j_natm_s        ; 040- jnatom_s    reg,label (byte)
  88.     DW    j_natm_l        ; 041- jnatom_l    reg,label (word)
  89.     DW    j_eq_s            ; 042- jeq_s    reg,label (byte)
  90.     DW    j_eq_l            ; 043- jeq_l    reg,label (word)
  91.     DW    j_neq_s            ; 044- jneq_s    reg,label (byte)
  92.     DW    j_neq_l            ; 045- jneq_l    reg,label (word)
  93.     DW    recompil        ; 046- (unused) formerly deref
  94.     DW    recompil        ; 047- (unused) formerly ref
  95.  
  96.     DW    call_lcl        ; 048- call    lbl,delta-level,delta-heap
  97.     DW    call_ltr        ; 049- call-tr    lbl,delta-level,delta-heap
  98.     DW    call_cc            ; 050- call/cc    lbl,delta-level,delta-heap
  99.     DW    cl_cctr            ; 051- call/cc-tr lbl delta-level,delta-heap
  100.     DW    call_clo        ; 052- call-cl    reg,number-args
  101.     DW    call_ctr        ; 053- call-cl-tr reg,number-args
  102.     DW    clcc_c            ; 054- call/cc-cl reg
  103.     DW    clcc_ctr        ; 055- call/cc-cl-tr reg
  104.  
  105.     DW    apply            ; 056- apply-cl    reg,arg
  106.     DW    apply_tr        ; 057- apply-cl-tr reg,arg
  107.     DW    execute            ; 058- execute    reg
  108.     DW    s_exit            ; 059- exit
  109.     DW    cr_close        ; 060- close    dest,label,number-args
  110.     DW    drop_env        ; 061- drop-env    count
  111.     DW    hash_env        ; 062- make-hashed-environment
  112.     DW    ld_fl_r            ; 063- ld-fluid-r dest,sym
  113.  
  114.     DW    ld_car            ; 064- car    dest,src
  115.     DW    ld_cdr            ; 065- cdr    dest,src
  116.     DW    ld_caar            ; 066- caar    dest,src
  117.     DW    ld_cadr            ; 067- cadr    dest,src
  118.     DW    ld_cdar            ; 068- cdar    dest,src
  119.     DW    ld_cddr            ; 069- cddr    dest,src
  120.     DW    ld_caaar        ; 070- caaar    dest,src
  121.     DW    ld_caadr        ; 071- caadr    dest,src
  122.  
  123.     DW    ld_cadar        ; 072- cadar    dest,src
  124.     DW    ld_caddr        ; 073- caddr    dest,src
  125.     DW    ld_cdaar        ; 074- cdaar    dest,src
  126.     DW    ld_cdadr        ; 075- cdadr    dest,src
  127.     DW    ld_cddar        ; 076- cddar    dest,src
  128.     DW    ld_cdddr        ; 077- cdddr    dest,src
  129.     DW    ld_caddd        ; 078- cadddr    dest,src
  130.     DW    s_cons            ; 079- cons    dest,car,cdr
  131.  
  132.     DW    addproc            ; 080- add    dest,src
  133.     DW    addi            ; 081- add-imm    dest,imm (signed byte)
  134.     DW    subproc            ; 082- sub    dest,src
  135.     DW    mulproc            ; 083- mul    dest,src
  136.     DW    muli            ; 084- mul-imm    dest,imm (signed byte)
  137.     DW    divproc            ; 085- div    dest,src
  138.     DW    divi            ; 086- div-imm    dest,imm (signed byte)
  139.     DW    quotient        ; 087- quotient    dest,src **integers only**
  140.  
  141.     DW    remainder        ; 088- remainder dest,src
  142.     DW    ld_car1            ; 089- %car    src=dest
  143.     DW    ld_cdr1            ; 090- %cdr    src=dest
  144.     DW    random            ; 091- %random    dest
  145.     DW    lt_p            ; 092- <    dest,src
  146.     DW    le_p            ; 093- <=    dest,src
  147.     DW    eq_n            ; 094- =    dest,src
  148.     DW    gt_p            ; 095- >    dest,src
  149.  
  150.     DW    ge_p            ; 096- >=    dest,src
  151.     DW    ne_p            ; 097- <>    dest,src
  152.     DW    maximum            ; 098- max    dest,src
  153.     DW    minimum            ; 099- min    dest,src
  154.     DW    eq_p            ; 100- eq?    dest,src
  155.     DW    eqv_p            ; 101- eqv?    dest,src
  156.     DW    equal_p            ; 102- equal?    dest,src
  157.     DW    memq            ; 103- memq    dest,src
  158.  
  159.     DW    memv            ; 104- memv    dest,src
  160.     DW    member            ; 105- member    dest,src
  161.     DW    reverseb        ; 106- reverse!    list
  162.     DW    not_yet            ; 107- reverse    list
  163.     DW    assq            ; 108- assq    obj,list
  164.     DW    assv            ; 109- assv    obj,list
  165.     DW    assoc            ; 110- assoc    obj,list
  166.     DW    s_list            ; 111- list    obj
  167.  
  168.     DW    appendb            ; 112- append!    list,obj
  169.     DW    append            ; 113- append    list,obj
  170.     DW    not_yet            ; 114- delq!    obj,list
  171.     DW    not_yet            ; 115- delete!    obj,list
  172.     DW    getprop            ; 116- get-prop    name,prop
  173.     DW    putprop            ; 117- put-prop    name,val,prop
  174.     DW    proplist        ; 118- proplist    name
  175.     DW    remprop            ; 119- remprop    name,prop
  176.  
  177.     DW    list2            ; 120- list2    dest=src1,src2
  178.     DW    not_yet            ; 121- list-ref    dest=src1,src2
  179.     DW    l_tail            ; 122- list-tail dest,count
  180.     DW    divide            ; 123- divide dest,src **integers only**
  181.     DW    modulo            ; 124- modulo dest, src
  182.     DW    b_xor            ; 125- bitwise-xor dest=src1,src2
  183.     DW    b_and            ; 126- bitwise-and dest=src1,src2
  184.     DW    b_or            ; 127- bitwise-or dest=src1,src2
  185.  
  186. ;    Note:    the second half of the opcodes are "second class" opcodes,
  187. ;    in that TIPC register bh will not be zero at the entry to the
  188. ;    support routine.    For the following instructions, bh will
  189. ;    contain the value one (1).
  190.  
  191.     DW    atom_p            ; 128- atom?    dest
  192.     DW    closur_p        ; 129- closure?    dest
  193.     DW    code_p            ; 130- code?    dest
  194.     DW    contin_p        ; 131- continuation? dest
  195.     DW    even_p            ; 132- even?    dest
  196.     DW    float_p            ; 133- float?    dest
  197.     DW    fluid_p            ; 134- fluid-bound? dest
  198.     DW    integr_p        ; 135- integer?    dest
  199.  
  200.     DW    null_p            ; 136- null?    dest
  201.     DW    number_p        ; 137- number?    dest
  202.     DW    odd_p            ; 138- odd?    dest
  203.     DW    pair_p            ; 139- pair?    dest
  204.     DW    port_p            ; 140- port?    dest
  205.     DW    proc_p            ; 141- proc?    dest
  206.     DW    inline_p        ; 142- inline?    dest
  207.     DW    string_p        ; 143- string?    dest
  208.  
  209.     DW    symbol_p        ; 144- symbol?    dest
  210.     DW    vector_p        ; 145- vector?    dest
  211.     DW    eq_z_p            ; 146- zero?    dest
  212.     DW    lt_z_p            ; 147- negative? dest
  213.     DW    gt_z_p            ; 148- positive? dest
  214.     DW    sabs            ; 149- abs    dest
  215.     DW    float            ; 150- float    dest
  216.     DW    minus            ; 151- minus    dest
  217.  
  218.     DW    sfloor            ; 152- floor    dest
  219.     DW    sceiling        ; 153- ceiling    dest
  220.     DW    struncat        ; 154- truncate    dest
  221.     DW    sround            ; 155- round    dest
  222.     DW    char_p            ; 156- char?    dest
  223.     DW    env_p            ; 157- env?     dest
  224.     DW    not_op
  225.     DW    not_op
  226.  
  227.     DW    asc_char        ; 160- asc->char reg
  228.     DW    char_asc        ; 161- char->asc reg
  229.     DW    str_str            ; 162- %str-str str,start,end,str,dir,case
  230.     DW    not_op
  231.     DW    not_op
  232.     DW    slength            ; 165- length    list
  233.     DW    lst_pair        ; 166- last-pair list
  234.     DW    substring        ; 167- substr    str,pos,len
  235.  
  236.     DW    vec_allo        ; 168- alloc-vec dest
  237.     DW    vec_size        ; 169- vect-length dest
  238.     DW    vec_fill        ; 170- vect-fill vect,val
  239.     DW    not_yet            ; 171- make-pack-vect len,bits/elem,signed?
  240.     DW    s_disply        ; 172- %substr-display str,start,end,row,wind
  241.     DW    unread_char        ; 173- unread-char port
  242.     DW    set_tim            ; 174- %start-timer src=ticks
  243.     DW    rst_tim            ; 175- %stop-timer dest=ticks remaining
  244.  
  245.     DW    p_open            ; 176- open-port filename,mode
  246.     DW    p_close            ; 177- close-port port
  247.     DW    spprin1            ; 178- prin1    obj,port
  248.     DW    spprinc            ; 179- princ    obj,port
  249.     DW    spprint            ; 180- print    obj,port
  250.     DW    spnewlin        ; 181- newline    port
  251.     DW    push_hist        ; 182- %push-history
  252.     DW    get_hist        ; 183- %get-history
  253.  
  254.     DW    prt_len            ; 184- print-length obj
  255.     DW    clr_hist        ; 185- clear-history
  256.     DW    srd_line        ; 186- read-line dest=src (src={port})
  257.     DW    srd_atom        ; 187- read-atom dest=src (src={port})
  258.     DW    read_char        ; 188- read-char dest=src
  259.     DW    trns_chg        ; 189- %transcript src
  260.     DW    rd_char_rdy        ; 190- read-char-ready? dest=src
  261.     DW    sfasl            ; 191- fasl    string
  262.  
  263.     DW    ch_eq_p            ; 192- char=    char1,char2
  264.     DW    ch_eq_ci        ; 193- char-equal? char1,char2
  265.     DW    ch_lt_p            ; 194- char<    char1,char2
  266.     DW    ch_lt_ci        ; 195- char-less? char1,char2
  267.     DW    ch_up            ; 196- char-upcase char
  268.     DW    ch_down            ; 197- char-downcase char
  269.     DW    str_lng            ; 198- string-length string
  270.     DW    st_ref            ; 199- string-ref string,index
  271.  
  272.     DW    st_set            ; 200- string-set! string,index,char
  273.     DW    make_str        ; 201- make-string length,char
  274.     DW    str_fill        ; 202- string-fill! string,char
  275.     DW    str2sym            ; 203- string->symbol string
  276.     DW    str2usym        ; 204- string->uninterned-symbol string
  277.     DW    sym2str            ; 205- symbol->string symbol
  278.     DW    srch_nx            ; 206- srch-next-char str,start,end,charset
  279.     DW    srch_pr            ; 207- srch-prev-char str,start,end,charset
  280.  
  281.     DW    make_win        ; 208- make-window label
  282.     DW    set_w_at        ; 209- set-wind-attr wind,attr,value
  283.     DW    get_wind        ; 210- get-wind-attr wind,attr
  284.     DW    clr_wind        ; 211- clear-window wind
  285.     DW    save_win        ; 212- save-window wind
  286.     DW    rest_win        ; 213- restore-wind wind
  287.     DW    s_append        ; 214- %str-append R(d=s1),R(s2),...,R(s7)
  288.     DW    sgraph            ; 215- %graphics len, R(d=s1),R(s2),...
  289.  
  290.     DW    sreify            ; 216- %reify    R(s1=d),R(s2) ;obj,indx
  291.     DW    mk_env            ; 217- mk-env    R(d)
  292.     DW    env_par            ; 218- env-par    R(d=s1) ; s1=env
  293.     DW    env_lu            ; 219- env-lu    R(d=s1),R(s2) ; sym,env
  294.     DW    def_env            ; 220- def-env    R(d=s1),R(s2),R(s3) sve
  295.     DW    push_env        ; 221- push-env    C(s1) ; s1=list of syms
  296.     DW    drop_env        ; 222- drop-env
  297.     DW    ld_env            ; 223- ld-env    R(d),C(s1) ; s1=symbol
  298.  
  299.     DW    st_env            ; 224- st-env    R(d=s1),C(s2) ; val,sym
  300.     DW    set_gnv            ; 225- set-glob-env! R(s1) ; s1=env
  301.     DW    sreifyb            ; 226- %reify!    R(s1),R(s2),R(s3);o,i,v
  302.     DW    obj_hash        ; 227- object-hash R(d=s1)
  303.     DW    obj_unhs        ; 228- object-unhash R(d=s1)
  304.     DW    reify_s            ; 229- reify-stack R(d=s1)
  305.     DW    reify_sb        ; 220- reify-stack! R(s1),R(s2)
  306.     DW    sfpos            ; 231- set-file-position!
  307.  
  308.     DW    s_esc            ; 232- %esc    len, R(d=s1),R(s2),...
  309.     DW    smouse            ; 233- %mouse    len, R(d=s1),R(s2),...
  310.     DW    recompil        ; 234- unused (formerly %esc3)
  311.     DW    recompil        ; 235- unused (formerly %esc4)
  312.     DW    recompil        ; 236- unused (formerly %esc5)
  313.     DW    recompil        ; 237- unused (formerly %esc6)
  314.     DW    recompil        ; 238- unused (formerly %esc7)
  315.     DW    recompil        ; 239- unused (formerly %xesc)
  316.  
  317.     DW    port_make        ; 240- make-port R(d=type), R(srce)
  318.     DW    port_get        ; 241- %port-get-attribute  R(d=port), R(s1)
  319.     DW    port_set        ; 242- %port-set-attribute! R(d=port), R(s1), R(s2)
  320.     DW    port_char        ; 243- %read-char
  321.     DW    port_line        ; 244- %read-line
  322.     DW    port_ready        ; 245- %char-ready?
  323.     DW    port_peek        ; 246- %peek-char
  324.     DW    sgc2            ; 247- gc-with-compaction
  325.  
  326.     DW    exit_op            ; 248- halt (return to MS-DOS)
  327.     DW    gc            ; 249- %garbage-collect
  328.     DW    recompil        ; 250- unused (formerly %internal-time)
  329.     DW    reset            ; 251- reset
  330.     DW    s_reset            ; 252- scheme-reset
  331.     DW    clr_regs        ; 253- %clear-registers
  332.     DW    not_op            ; 254- (reserved for escape)
  333.     DW    debug_op        ; 255- %begin-debug
  334.  
  335. UDATASEG
  336. reset_bp DW    ?            ; initial value of bp for reset purposes
  337. CODESEG
  338.  
  339. ;************************************************************************
  340. ;*        Macro support for out-of-line calls to Borland C    *
  341. ;************************************************************************
  342. PROC    get1parm NEAR
  343.     xor    ax, ax
  344.     get1op
  345.     add    ax, OFFSET regs        ; compute address of register
  346.     save    <si>
  347.     ret
  348. ENDP    get1parm
  349.  
  350. PROC    get2parm NEAR
  351.     get2op
  352.     xor    bx, bx
  353.     xchg    bl, ah
  354.     add    bx, OFFSET regs        ; compute address of register
  355.     add    ax, OFFSET regs
  356.     save    <si>
  357.     ret
  358. ENDP    get2parm
  359.  
  360. PROC    get3parm NEAR
  361.     xor    cx, cx
  362.     get1op
  363.     mov    cx, ax
  364.     get2op
  365.     xor    bx, bx
  366.     xchg    bl, ah
  367.     add    cx, OFFSET regs        ; and compute register address
  368.     add    bx, OFFSET regs        ; compute address of register
  369.     add    ax, OFFSET regs
  370.     save    <si>
  371.     ret
  372. ENDP    get3parm
  373.  
  374. PROC    get4parm NEAR
  375.     get2op
  376.     xor    dx, dx
  377.     xchg    dl, ah            ; copy 2nd operand register number
  378.     mov    cx, ax            ; copy 1st operand register number
  379.     get2op
  380.     xor    bx, bx
  381.     xchg    bl, ah            ; copy 4th operand register number
  382.     add    dx, OFFSET regs
  383.     add    cx, OFFSET regs
  384.     add    bx, OFFSET regs        ; compute address of register
  385.     add    ax, OFFSET regs
  386.     save    <si>
  387.     ret
  388. ENDP    get4parm
  389.  
  390. ;************************************************************************
  391. ;*            Common Support for EVEN?/ODD?            *
  392. ;*                                    *
  393. ;* Input Parameters:    es:[si] - pointer to even?/odd? instruction's    *
  394. ;*                operand.                *
  395. ;*            dx ------ text address for "EVEN?" or "ODD?" to    *
  396. ;*                be used to create an error message if    *
  397. ;*                an error is detected.            *
  398. ;*                                    *
  399. ;* Output Parameters:    Zero Flag (condition code) - 0 => even number    *
  400. ;*                            1 => odd number    *
  401. ;*                                    *
  402. ;* Note:    If an invalid operand is detected, this routine exits    *
  403. ;*        to the Scheme debugger.                    *
  404. ;************************************************************************
  405. PROC    eo_which NEAR
  406.     get1op
  407.     mov    bx, ax            ; copy register number to bx
  408.     add    bx, OFFSET regs
  409.     cmp    [(REG bx).bpage], SPECFIX*2
  410.     jne    @@notfix
  411.     test    [(REG bx).disp], 1
  412.     ret
  413. @@notfix:
  414.     mov    di, [(REG bx).page]
  415.     cmp    [ptype+di], BIGTYPE    ; is operand a bignum?
  416.     jne    @@notbig
  417.     push    es            ; saves es
  418.     ldpage    es, di
  419.     mov    di, [(REG bx).disp]
  420.     test    [BYTE (BIGDEF es:di).data.lsw], 1 ; test LSB of bignum
  421.     pop    es            ; restore es register
  422.     ret
  423. @@notbig:
  424.     mov    ax, 1
  425.     call    set_src_error C, dx, ax, bx
  426.     pop    ax            ; drop the caller's address
  427.     jmp    sch_err
  428. ENDP    eo_which
  429.  
  430. ;************************************************************************
  431. ;*    Entry point to force debug mode prior to next VM instruction    *
  432. ;************************************************************************
  433. PROC C    force_debug FAR
  434. IFDEF    VMDEBUG
  435.     mov    ax, [cs:$$sm$debug]
  436.     mov    [cs:$$sm$entry], ax
  437. ENDIF
  438.     ret
  439. ENDP    force_debug
  440.  
  441. ;************************************************************************
  442. ;*    Entry point to force a timeout prior to next VM instruction.    *
  443. ;*    This will be called from the tick routine in STIMER.ASM.    *
  444. ;************************************************************************
  445. PROC C    force_timeout FAR
  446.     mov    ax, [cs:$$sm$timer]
  447.     xchg    [cs:$$sm$entry], ax
  448.     mov    [cs:reset_timer], ax
  449.     ret
  450. ENDP    force_timeout
  451.  
  452. ;************************************************************************
  453. ;*    Interrupt handler for mouse                    *
  454. ;************************************************************************
  455. UDATASEG
  456. STRUC    MOUSESTATE
  457. flags    DW    ?
  458. state    DW    ?
  459. x    DW    ?
  460. y    DW    ?
  461. x_mickeys    DW    ?
  462. y_mickeys    DW    ?
  463. time    DD    ?
  464. ENDS
  465. mstate    MOUSESTATE    6 dup (?)    ; provide for 6 events,
  466. DATASEG                    ; or a triple-click
  467. mstptr    DW    mstate
  468. CODESEG
  469. PROC C    mouse_handler    FAR
  470.     push    ds
  471.     push    bx            ; save bx, an useful pointer
  472.     mov    bx, DGROUP        ; and state-holder
  473.     mov    ds, bx
  474.  
  475.     cli                ; don't allow reentrance here
  476.     mov    bx, [mstptr]
  477.     cmp    bx, OFFSET mstate + 6 * (SIZE MOUSESTATE)
  478.     jae    @@abort            ; sorry, no room left
  479.     add    [mstptr], SIZE MOUSESTATE
  480.     sti
  481.     mov    [(MOUSESTATE bx).flags], ax
  482.     mov    [(MOUSESTATE bx).x], cx
  483.     mov    [(MOUSESTATE bx).y], dx
  484.     mov    [(MOUSESTATE bx).x_mickeys], si
  485.     mov    [(MOUSESTATE bx).y_mickeys], di
  486.     pop    si            ; restore mouse state
  487.     mov    [(MOUSESTATE bx).state], si
  488.     push    bx
  489.     call    clock C
  490.     pop    bx
  491.     mov    [WORD LOW (MOUSESTATE bx).time], ax
  492.     mov    [WORD HIGH (MOUSESTATE bx).time], dx
  493.  
  494.     mov    ax, [cs:$$sm$mouse]
  495.     xchg    [cs:$$sm$entry], ax
  496.     cmp    ax, [cs:$$sm$mouse]    ; did we already interrupt?
  497.     je    @@alreadydone
  498.     mov    [cs:reset_mouse], ax
  499. @@alreadydone:
  500.     pop    ds
  501.     ret
  502. @@abort:
  503.     sti
  504.     pop    bx
  505.     pop    ds
  506.     ret
  507. ENDP
  508.  
  509. ;************************************************************************
  510. ;*    Entry point to process shift-break prior to next VM instruction    *
  511. ;************************************************************************
  512. reset_sb DW    0
  513. PROC    shft_brk FAR
  514.     push    es si di ax
  515.     mov    ax, @data
  516.     mov    es, ax
  517.     inc    [BYTE es:s_break]
  518.     cmp    [WORD es:vm_debug], 0
  519.     jz    @@notVMmode
  520.     call    force_debug C        ; if we're in VM_debug mode, jump
  521.     jmp    @@abort
  522. @@notVMmode:
  523.     mov    ax, [cs:$$sm$break]    ; else, force a trap to the debugger
  524.     cmp    ax, [cs:$$sm$entry]    ; Shift-Brk already depressed?
  525.     je    @@abort
  526.     xchg    [cs:$$sm$entry], ax    ; else enter scheme debugger on
  527.     mov    [cs:reset_sb], ax    ; next vm instruction
  528. @@abort:
  529.     pop    ax di si es
  530.     ret
  531. ENDP    shft_brk
  532.  
  533. PROC    run FAR
  534.     mov    ax, [cs:$$sm$go]    ; modify interpreter loop to disable
  535.     mov    [cs:$$sm$entry], ax    ; instruction level trace capability
  536. ;    jmp    interp            ; fall through
  537. ENDP    run
  538.  
  539. ;************************************************************************
  540. ;*        Scheme VM interpreter entry point            *
  541. ;************************************************************************
  542. ;* If you change the USES registers section of proc header, update the    *
  543. ;* following constant (used for stack restore after any serious error)    *
  544. ;************************************************************************
  545. USESSIZE EQU    2 * 2
  546. PROC C    interp FAR USES si di, $$entry:WORD, $$retcode:WORD, @@instcount:WORD
  547.     LOCAL    save_dx, save_cx, save_bx, save_ax, save_di, save_si = LCLSIZE
  548. IFDEF    VMDEBUG
  549. DATASEG
  550. NULLEN  =    8            ; 8 first words of DATASEG...
  551. @@null    DW    NULLEN DUP (?)        ; ... should be constants
  552. CODESEG
  553.     push    ds
  554.     pop    es
  555.     xor    si, si
  556.     lea    di, [@@null]
  557.     mov    cx, NULLEN
  558.     rep    movsw
  559. ENDIF
  560.     mov    [reset_bp], bp        ; Set up initial interpreter parameters
  561.     mov    si, [$$entry]
  562.     mov    si, [si]
  563.     mov    bx, [cb_reg.page]
  564.     cmp    [ptype+bx], CODETYPE    ; does page contain code ?
  565.     jne    @@notcode
  566.     ldpage    es, bx
  567.     jmp    next
  568. @@notcode:
  569.     lea    ax, [@@codeblock]
  570. DATASEG
  571. @@codeblock DB    "[VM INTERNAL ERROR] %x:%04x isn't a code base", LF, 0
  572. CODESEG
  573.     call    zprintf C, ax, bx, [cb_reg.disp]
  574.     mov    ax, RV_CLOBBERED
  575.     jmp    in_debug
  576.  
  577. IFDEF    VMDEBUG
  578. @@nexttrace:                ; **** FIRST PART OF TESTS: INTERNALS
  579.     lea    dx, [@@backward]
  580. DATASEG
  581. @@backward DB    "[VM INTERNAL ERROR] interp: instruction preceding %x:%04x set direction flag", LF, 0
  582. CODESEG
  583.     pushf                ; Check direction flag is forward
  584.     pop    ax
  585.     test    ax, 400h        ; test direction flag
  586.     cld
  587.     jnz    @@clobbered
  588.  
  589.     lea    dx, [@@stackptr]
  590. DATASEG
  591. @@stackptr DB    "[VM INTERNAL ERROR] interp: instruction preceding %x:%04x corrupted 8086 stack", LF, 0
  592. CODESEG
  593.     lea    ax, [BP-LCLSIZE-USESSIZE] ; load the theoretic SP
  594.     cmp    ax, sp
  595.     jne    @@clobbered
  596.  
  597.     lea    dx, [@@heapstr]
  598. DATASEG
  599. @@heapstr DB    "[VM INTERNAL ERROR] interp: instruction preceding %x:%04x corrupted 8086 heap", LF, 0
  600. CODESEG
  601.     push    es
  602.     call    heapcheck C
  603.     pop    es
  604.     or    ax, ax
  605.     js    @@clobbered
  606.  
  607.     lea    dx, [@@nullstr]
  608. DATASEG
  609. @@nullstr DB    "[VM INTERNAL ERROR] interp: null ptr assignment at instruction preceding %x:%04x", LF, 0
  610. CODESEG
  611.     push    es
  612.     push    si
  613.     push    ds            ; Compare from [DS:0] to [DS:@@null]
  614.     pop    es
  615.     xor    si, si
  616.     lea    di, [@@null]
  617.     mov    cx, NULLEN
  618.     repe    cmpsw
  619.     pop    si
  620.     pop    es
  621.     je    @@notclobbered
  622.  
  623. @@clobbered:                ; **** GENERIC CLOBBERED ANNOUNCE
  624.     mov    ax, [cb_reg.page]
  625.     corpage ax
  626.     call    zprintf C, dx, ax, si
  627.     mov    bx, [$$retcode]        ; return the intructions already done
  628.     mov    ax, [@@instcount]
  629.     mov    [bx], ax
  630.     mov    ax, RV_CLOBBERED
  631.     jmp    in_debug
  632.  
  633. @@notclobbered:                ; **** SECOND PART OF TESTS: VM
  634.     lea    dx, [@@reg0]
  635. DATASEG
  636. @@reg0    DB    "[VM INTERNAL ERROR] interp: instruction preceding %x:%04x clobbered a register", LF, 0
  637. CODESEG
  638.     cmp    [reg0.page], NIL_PAGE*2 ; Check R0 is still nil
  639.     jne    @@clobbered
  640.     cmp    [reg0.disp], NIL_DISP
  641.     jne    @@clobbered
  642.  
  643.     push    es
  644.     mov    ax, NILPAGE        ; Verify that NILPAGE still contains
  645.     mov    es, ax            ; (() . ())
  646.     xor    di, di
  647.     mov    cx, 3
  648.     xor    ax, ax
  649.     repe    scasw
  650.     pop    es
  651.     jne    @@clobbered
  652.  
  653.                     ; Validate the contents of each of the Scheme registers
  654.     mov    cx, NUM_REGS        ; load number of register into cx (counter)
  655.     lea    di, [regs]
  656. @@checkregs:
  657.     mov    ax, [(REG di).page]
  658.     cmp    ax, SPECFIX*2        ; does register contain a fixnum?
  659.     je    @@regok
  660.     cmp    ax, SPECCHAR*2        ; does register contain a character?
  661.     je    @@regok
  662.     mov    bx, ax            ; save page number (times 2)
  663.     ror    ax, 1
  664.     cmp    ax, [nextpage]        ; is page number too large?
  665.     jae    @@clobbered
  666.     mov    ax, [(REG di).disp]
  667.     cmp    ax, [psize+bx]        ; is offset too big?
  668.     jae    @@clobbered
  669. @@regok:
  670.     add    di, size REG
  671.     loop    @@checkregs
  672.     call    @REG@check$qv C        ; check for other registers
  673. DATASEG
  674. @@regchk DB    "[VM INTERNAL ERROR] interp: instruction preceding %x:%04x clobbered class REG", LF, 0
  675. CODESEG
  676.     lea    dx, [@@regchk]
  677.     or    ax, ax
  678.     jnz    @@clobbered        ; **** END OF TESTS
  679.  
  680.     sub    [@@instcount], 1    ; 1 more instruction done
  681.     jae    @@nextgo
  682.     mov    ax, RV_PROCEED
  683.     jmp    in_exit
  684.  
  685. @@nextgo:
  686.     get1op                ; Fetch next instruction's opcode
  687.     mov    ah, 0
  688.     mov    bx, ax
  689.     shl    bx, 1            ; Multiply opcode by two for use as index
  690.     mov    di, bx
  691.     add    [WORD icount+bx+di], 1    ; accounting info
  692.     adc    [WORD icount+bx+di+2], 0
  693.     jmp    [op_table+bx]
  694.  
  695. LABEL    $$sm$trace    WORD
  696.     jmp    SHORT @@@trace+($-$$sm$entry) ; jump to overwrite "next" for debug
  697. @@@trace:
  698.     jmp    @@nexttrace
  699.  
  700. LABEL    $$sm$debug    WORD
  701.     jmp    SHORT @@@debug+($-$$sm$entry) ; jump to force debug mode
  702. @@@debug:
  703.     jmp    in_debug
  704. ENDIF
  705.  
  706. LABEL    $$sm$timer    WORD
  707.     jmp    SHORT @@@timer+($-$$sm$entry) ; jump to force timeout
  708. @@@timer:
  709.     jmp    timeout
  710.  
  711. LABEL    $$sm$mouse    WORD
  712.     jmp    SHORT @@@mouse+($-$$sm$entry) ; jump to force timeout
  713. @@@mouse:
  714.     jmp    mouseevent
  715.  
  716. LABEL    $$sm$break    WORD
  717.     jmp    SHORT @@@sdebug+($-$$sm$entry) ; jump to force Scheme debug mode
  718. @@@sdebug:
  719.     jmp    sc_debug
  720.  
  721. LABEL    $$sm$go    WORD
  722. IFDEF    HARDDEBUG
  723.     jmp    @@nexttrace
  724. ELSE
  725.     xor    ax, ax            ; same as in next
  726. ENDIF
  727. ;
  728. ; Following is the main vm interpreter loop. Note that the location at $$sm$entry
  729. ; can (and will be) code modified to jump into the debugger, and a trace loop.
  730. ;
  731. next_pc:
  732.     mov    si, [save_si]        ; Reload interpreter's PC
  733.     mov    bx, [cb_reg.page]
  734.     ldpage    es, bx
  735.     cld
  736. next:
  737. LABEL    $$sm$entry    WORD
  738. IFDEF    HARDDEBUG
  739.     jmp    @@nexttrace
  740. ELSE
  741.     xor    ax, ax            ; Clear high order BYTE of ax
  742. ENDIF
  743.     get1op
  744.     mov    bx, ax
  745.     shl    bx, 1
  746.     jmp    [op_table+bx]
  747.  
  748. ;************************************************************************
  749. ;*    Jump if nil, short    JNILS    reg,offset            *
  750. ;************************************************************************
  751. PROC    j_nil_s
  752.     get2op
  753.     mov    bl, al            ; copy register number
  754.     cmp    [regs+bx.bpage], 0    ; test for null pointer
  755.     jne    next
  756.     mov    al, ah
  757.     cbw                ; Sign extend short displacement
  758.     add    si, ax            ; Add jump offset to current PC
  759.     jmp    next
  760. ENDP    j_nil_s
  761.  
  762. ;************************************************************************
  763. ;*    Jump if not nil, short    JNNILS    reg,offset            *
  764. ;************************************************************************
  765. PROC    j_nnil_s
  766.     get2op
  767.     mov    bl, al            ; copy register number
  768.     cmp    [regs+bx.bpage], 0    ; test for null pointer
  769.     je    next
  770.     mov    al, ah
  771.     cbw                ; Sign extend short displacement
  772.     add    si, ax            ; Add jump offset to current PC
  773.     jmp    next
  774. ENDP    j_nnil_s
  775.  
  776. ;************************************************************************
  777. ;*    Jump if atom,short    JATOMS    reg,offset            *
  778. ;************************************************************************
  779. PROC    j_atm_s
  780.     get2op
  781.     mov    bl, al            ; copy register number to test
  782.     test    [attrib+bx], ATOM    ; test for atom attribute
  783.     jz    next
  784.     mov    al, ah            ; position branch offset and
  785.     cbw                ; sign extend to 16 bits
  786.     add    si, ax            ; add jump offset to current PC
  787.     jmp    next
  788. ENDP    j_atm_s
  789.  
  790. ;************************************************************************
  791. ;*    Jump if not atom,short    JNATOMS reg,offset            *
  792. ;************************************************************************
  793. PROC    j_natm_s
  794.     lods    [WORD es:si]        ; Load register, offset
  795.     mov    bl, al            ; copy register number to test
  796.     test    [attrib+bx], ATOM    ; test for atom attribute
  797.     jnz    next
  798.     mov    al, ah            ; position branch offset and
  799.     cbw
  800.     add    si, ax            ; add jump offset to current PC
  801.     jmp    next
  802. ENDP    j_natm_s
  803.  
  804. ;************************************************************************
  805. ;*    Jump if eq?, short    JEQS    src1,src2,offset        *
  806. ;************************************************************************
  807. PROC    j_eq_s
  808.     get2op
  809.     mov    bl, ah
  810.     mov    di, bx
  811.     mov    bl, al            ; copy src1 register number
  812.     get1op
  813.     cbw
  814. in_j_eq_s:
  815.     mov    cx, [regs+bx.disp]
  816.     cmp    cx, [regs+di.disp]    ; are displacements eq?
  817.     jne    next
  818.     mov    cl, [regs+bx.bpage]
  819.     cmp    cl, [regs+di.bpage]    ; are page numbers eq?
  820.     jne    next
  821.     add    si, ax            ; add offset to current PC
  822.     jmp    next
  823. ENDP    j_eq_s
  824.  
  825. ;************************************************************************
  826. ;*    Jump if not eq?, short    JNEQS    src1,src2,offset        *
  827. ;************************************************************************
  828. PROC    j_neq_s
  829.     get2op
  830.     mov    bl, ah
  831.     mov    di, bx
  832.     mov    bl, al            ; copy src1 register number
  833.     get1op
  834.     cbw
  835. in_j_neq_s:
  836.     mov    cx, [regs+bx.disp]
  837.     cmp    cx, [regs+di.disp]    ; are displacements eq?
  838.     jne    @@jump
  839.     mov    cl, [regs+bx.bpage]
  840.     cmp    cl, [regs+di.bpage]    ; are page numbers eq?
  841.     jne    @@jump
  842.     jmp    next
  843. @@jump:
  844.     add    si, ax            ; add offset to current PC
  845.     jmp    next
  846. ENDP    j_neq_s
  847.  
  848. ;************************************************************************
  849. ;*    Jump if eq?, long    JEQL    src1,src2,offset        *
  850. ;************************************************************************
  851. PROC    j_eq_l
  852.     get2op
  853.     mov    bl, ah
  854.     mov    di, bx
  855.     mov    bl, al            ; copy src1 register number
  856.     lods    [WORD es:si]        ; load branch displacement
  857.     jmp    in_j_eq_s
  858. ENDP    j_eq_l
  859.  
  860. ;************************************************************************
  861. ;*    Jump if not eq?, long    JNEQL    src1,src2,offset        *
  862. ;************************************************************************
  863. PROC    j_neq_l
  864.     get2op
  865.     mov    bl, ah
  866.     mov    di, bx
  867.     mov    bl, al            ; copy src1 register number
  868.     lods    [WORD es:si]        ; load branch displacement, save
  869.     jmp    in_j_neq_s
  870. ENDP    j_neq_l
  871.  
  872. ;************************************************************************
  873. ;*    Jump if nil, long    JNILL    reg,offset            *
  874. ;************************************************************************
  875. PROC    j_nil_l
  876.     get1op
  877.     mov    bl, al
  878.     cmp    [regs+bx.bpage], 0    ; Test for null pointer
  879.     jne    @@dontjump
  880.     lods    [WORD es:si]        ; load branch offset
  881.     add    si, ax            ; Add jump offset to current PC
  882.     jmp    next
  883. @@dontjump:
  884.     add    si, 2
  885.     jmp    next            ; Return to interpreter
  886. ENDP    j_nil_l
  887.  
  888. ;************************************************************************
  889. ;*    Jump if not nil, long    JNNILL    reg,offset            *
  890. ;************************************************************************
  891. PROC    j_nnil_l
  892.     get1op
  893.     mov    bl, al            ; copy register number
  894.     cmp    [regs+bx.bpage], 0    ; Test for null pointer
  895.     jz    @@dontjump
  896.     lods    [WORD es:si]        ; load branch offset
  897.     add    si, ax            ; Add jump offset to current PC
  898.     jmp    next
  899. @@dontjump:
  900.     add    si, 2
  901.     jmp    next
  902. ENDP    j_nnil_l
  903.  
  904. ;************************************************************************
  905. ;*    Jump if atom,long    JATOMS    reg,offset            *
  906. ;************************************************************************
  907. PROC    j_atm_l
  908.     get1op
  909.     mov    bl, al            ; copy register number to test
  910.     test    [attrib+bx], ATOM    ; test for atom attribute
  911.     jz    @@dontjump
  912.     lods    [WORD es:si]        ; load branch offset
  913.     add    si, ax            ; add jump offset to current PC
  914.     jmp    next
  915. @@dontjump:
  916.     add    si, 2
  917.     jmp    next
  918. ENDP    j_atm_l
  919.  
  920. ;************************************************************************
  921. ;*    Jump if not atom,long    JNATOMS reg,offset            *
  922. ;************************************************************************
  923. PROC    j_natm_l
  924.     get1op
  925.     mov    bl, al            ; copy register number to test
  926.     test    [attrib+bx], ATOM    ; test for atom attribute
  927.     jnz    @@dontjump
  928.     lods    [WORD es:si]        ; load branch offset
  929.     add    si, ax            ; add jump offset to current PC
  930.     jmp    next
  931. @@dontjump:
  932.     add    si, 2
  933.     jmp    next
  934. ENDP    j_natm_l
  935.  
  936. ;************************************************************************
  937. ;*    Jump unconditionally, short                    *
  938. ;************************************************************************
  939. PROC    jmp_shrt
  940.     get1op
  941.     cbw                ; sign extend the BYTE offset
  942.     add    si, ax
  943.     jmp    next
  944. ENDP    jmp_shrt
  945.  
  946. ;************************************************************************
  947. ;*    Jump unconditionally, long                    *
  948. ;************************************************************************
  949. PROC    jmp_long
  950.     lods    [WORD es:si]
  951.     add    si, ax
  952.     jmp    next
  953. ENDP    jmp_long
  954.  
  955. ;************************************************************************
  956. ;*    Move register to register:    COPY        dest,src    *
  957. ;************************************************************************
  958. PROC    copy
  959.     get2op
  960.     mov    bl, ah            ; copy source register number into
  961.     mov    cx, [regs+bx.disp]
  962.     mov    dl, [regs+bx.bpage]
  963.     mov    bl, al            ; copy destination register number
  964.     mov    [regs+bx.disp], cx
  965.     mov    [regs+bx.bpage], dl
  966.     jmp    next
  967. ENDP    copy
  968.  
  969. ;************************************************************************
  970. ;*                             al   ah    *
  971. ;*    Load constant from constant's area    LD-CONST dest,const    *
  972. ;*                                    *
  973. ;* Purpose:    Interpreter support for loading a compile time constant    *
  974. ;*        into a register of the Scheme virtual machine.        *
  975. ;************************************************************************
  976. PROC    ld_const
  977.     get2op
  978.     mov    bl, ah            ; load constant number 
  979.     mov    di, bx
  980.     shl    di, 1
  981.     add    di, [cb_reg.disp]
  982.     mov    dl, [(CODEDEF es:bx+di).consts.page]
  983.     mov    cx, [(CODEDEF es:bx+di).consts.disp]
  984.     mov    bl, al            ; load destination register number
  985.     mov    [regs+bx.bpage], dl
  986.     mov    [regs+bx.disp], cx
  987.     jmp    next
  988. ENDP    ld_const
  989.  
  990. ;************************************************************************
  991. ;*                             al   ah    *
  992. ;*    Load immediate value            LD-IMM     dest,imm    *
  993. ;*                                    *
  994. ;* Purpose:    Interpreter support for loading an immediate value    *
  995. ;*        into a register of the Scheme virtual machine.        *
  996. ;************************************************************************
  997. PROC    ld_imm
  998.     get2op
  999.     mov    bl, al            ; copy the destination register number
  1000.     mov    al, ah            ; isolate and sign extend the
  1001.     cbw                ;    immediate value
  1002.     mov    [regs+bx.disp], ax
  1003.     mov    [regs+bx.bpage], SPECFIX*2
  1004.     jmp    next
  1005. ENDP    ld_imm
  1006.  
  1007. ;************************************************************************
  1008. ;* Load nil                        ld-nil    dest    *
  1009. ;*                                    *
  1010. ;* Purpose:    Scheme interpreter support to load the value "nil" into    *
  1011. ;*        a VM register                        *
  1012. ;************************************************************************
  1013. PROC    ld_nil
  1014.     get1op
  1015.     mov    bl, al
  1016.     xor    ax, ax
  1017.     mov    [regs+bx.bpage], al    ; store value of 'nil into
  1018.     mov    [regs+bx.disp], ax    ; destination register
  1019.     jmp    next
  1020. ENDP    ld_nil
  1021.  
  1022. ;************************************************************************
  1023. ;*                             al   ah    *
  1024. ;* Vector Load with short offset        LD-VEC-S vect,offset    *
  1025. ;*                                    *
  1026. ;* Purpose:    Scheme interpreter support for vector load instructions    *
  1027. ;*        with short offset fields                *
  1028. ;************************************************************************
  1029. PROC    ld_off_s
  1030.     get2op
  1031.     mov    bl, al            ; copy vector pointer/destination reg
  1032.     mov    di, bx
  1033.     mov    al, ah
  1034.     cbw
  1035.     jmp    in_ld_off_rs
  1036. ENDP    ld_off_s
  1037.  
  1038. ;************************************************************************
  1039. ;*                             al   ax    *
  1040. ;* Vector Load with long offset            LD-VEC-L vect,offset    *
  1041. ;*                                    *
  1042. ;* Purpose:    Scheme interpreter support for vector load instructions    *
  1043. ;*        with long offset fields                    *
  1044. ;************************************************************************
  1045. PROC    ld_off_l
  1046.     mov    dx, 4            ; record length of this instruction
  1047.     get1op
  1048.     mov    di, ax
  1049.     lods    [WORD es:si]
  1050.     jmp    in_ld_off_r
  1051. ENDP    ld_off_l
  1052.  
  1053. ;************************************************************************
  1054. ;*                             al   ah    *
  1055. ;* Vector Load with register offset        LD-VEC-R vect,offset    *
  1056. ;*                                    *
  1057. ;* Purpose:    Scheme interpreter support for vector load instructions    *
  1058. ;*        with register offset fields                *
  1059. ;************************************************************************
  1060. PROC    ld_off_r
  1061.     get2op
  1062.     mov    bl, al            ; copy vector pointer/destination reg
  1063.     mov    di, bx
  1064.     mov    bl, ah            ; copy number of index register
  1065.     cmp    [regs+bx.bpage], SPECFIX*2 ; index a fixnum?
  1066.     je    @@argsok
  1067. @@badarg:
  1068.     lea    bx, [@@msg]
  1069. DATASEG
  1070. @@msg    DB    "VECTOR-REF", 0
  1071. CODESEG
  1072.     jmp    src_err
  1073. @@argsok:
  1074.     mov    ax, [regs+bx.disp]
  1075. in_ld_off_rs:
  1076.     mov    dx, 3            ; record length of this instruction
  1077. in_ld_off_r:
  1078.     save    <si>
  1079.     mov    cx, ax            ; multiply the index value by 3
  1080.     shl    ax, 1
  1081.     add    ax, cx
  1082.     jl    @@bounds
  1083.     mov    bl, [regs+di.bpage]
  1084.     cmp    [ptype+bx], VECTTYPE    ; does it point to a vector?
  1085.     jne    @@badarg
  1086.     ldpage    es, bx
  1087.     mov    si, [regs+di.disp]
  1088.     add    ax, OFFSET (TYPE VECDEF).data
  1089.     cmp    ax, [(VECDEF es:si).len] ; is reference within bounds?
  1090.     jge    @@bounds
  1091.     add    si, ax            ; add index to vector offset
  1092.     mov    al, [(POINTER es:si).page]
  1093.     mov    bx, [(POINTER es:si).disp]
  1094.     mov    [regs+di.bpage], al
  1095.     mov    [regs+di.disp], bx
  1096.     jmp    next_pc
  1097. @@bounds:
  1098.     lea    ax, [@@msg]
  1099. in_off_error:
  1100.     restore <si>
  1101.     sub    si, dx            ; back up to start of instruction
  1102.     push    es            ; saves es over C call
  1103.     call    disassemble C, ax, si    ; disassemble instruction for *irritant*
  1104.     mov    ax, 1
  1105.     mov    bx, VECTOR_OFFSET_ERROR
  1106.     call    set_numeric_error C, ax, bx, [tmp_adr]
  1107.     pop    es
  1108.     restore <si>
  1109.     jmp    sch_err
  1110. ENDP    ld_off_r
  1111.  
  1112. ;************************************************************************
  1113. ;*                         al   ah     al        *
  1114. ;* Vector Store with short offset    ST-VEC-S vect,offset,src    *
  1115. ;*                                    *
  1116. ;* Purpose:    Scheme interpreter support for vector store instructions*
  1117. ;*        with short offset fields                *
  1118. ;************************************************************************
  1119. PROC    st_off_s
  1120.     get2op
  1121.     mov    bl, al            ; copy vector pointer register
  1122.     mov    di, bx
  1123.     mov    al, ah
  1124.     cbw
  1125.     jmp    in_st_off_rs
  1126. ENDP    st_off_s
  1127.  
  1128. ;************************************************************************
  1129. ;*                         al   ax     al        *
  1130. ;* Vector Store with long offset    ST-VEC-L vect,offset,src    *
  1131. ;*                                    *
  1132. ;* Purpose:    Scheme interpreter support for vector store instructions*
  1133. ;*        with long offset fields                    *
  1134. ;************************************************************************
  1135. PROC    st_off_l
  1136.     mov    dx, 5            ; record length of this instruction
  1137.     get1op
  1138.     mov    di, ax
  1139.     lods    [WORD es:si]
  1140.     jmp    in_st_off_r
  1141. ENDP    st_off_l
  1142.  
  1143. ;************************************************************************
  1144. ;*                         al   ah     al        *
  1145. ;* Vector Store with register offset    ST-VEC-R vect,offset,src    *
  1146. ;*                                    *
  1147. ;* Purpose:    Scheme interpreter support for vector store instructions*
  1148. ;*        with register offset fields                *
  1149. ;************************************************************************
  1150. PROC    st_off_r
  1151.     get2op
  1152.     mov    bl, al            ; copy vector pointer register
  1153.     mov    di, bx
  1154.     mov    bl, ah            ; copy number of index register
  1155.     cmp    [regs+bx.bpage], SPECFIX*2 ; index a fixnum?
  1156.     jne    @@badarg
  1157.     mov    ax, [regs+bx.disp]
  1158. in_st_off_rs:
  1159.     mov    dx, 4
  1160. in_st_off_r:
  1161.     mov    cx, ax
  1162.     shl    ax, 1
  1163.     add    cx, ax            ; multiply the index value by 3
  1164.     get1op
  1165.     save    <si>
  1166.     jl    @@bounds        ; flags still set by 'add' !
  1167.     xor    ah, ah            ; ax is source reg
  1168.     mov    bl, [regs+di.bpage]    ; load page number for vector ptr
  1169.     cmp    [ptype+bx], VECTTYPE    ; does it point to a vector?
  1170.     jne    @@badarg
  1171.     ldpage    es, bx            ; load paragraph address for vector's page
  1172.     mov    si, [regs+di.disp]
  1173.     add    cx, OFFSET (TYPE VECDEF).data
  1174.     cmp    cx, [(VECDEF es:si).len] ; is reference within bounds?
  1175.     jge    @@bounds
  1176.     add    si, cx            ; add index to vector offset
  1177.     mov    di, ax            ; copy src reg # into di
  1178.     mov    al, [regs+di.bpage]
  1179.     mov    bx, [regs+di.disp]
  1180.     mov    [(POINTER es:si).page], al
  1181.     mov    [(POINTER es:si).disp], bx
  1182.     jmp    next_pc
  1183. @@bounds:
  1184.     lea    ax, [@@msg]
  1185. DATASEG
  1186. @@msg    DB    "VECTOR-SET!", 0
  1187. CODESEG
  1188.     jmp    in_off_error
  1189. @@badarg:
  1190.     lea    bx, [@@msg]
  1191.     jmp    src_err
  1192. ENDP    st_off_r
  1193.  
  1194. ;************************************************************************
  1195. ;*    Negation (minus obj)    MINUS dest                *
  1196. ;************************************************************************
  1197. PROC    minus
  1198.     get1op
  1199.     mov    di, ax
  1200.     cmp    [regs+di.page], SPECFIX*2
  1201.     jne    @@notfix
  1202.     mov    ax, [regs+di.disp]
  1203. in_minus:
  1204.     neg    ax            ; negate the immediate value
  1205.     jo    @@overflow
  1206.     mov    [regs+di.disp], ax
  1207.     jmp    next
  1208. @@notfix:
  1209.     mov    dx, MINUS_OP        ; indicate negation sub-opcode
  1210. in_arith:                ; Process unary operation out of line
  1211.     save    <si>
  1212.     add    di, OFFSET regs
  1213.     call    arith1 C, dx, di    ; call unary arithmetic support
  1214.     or    ax, ax            ; was error encountered?
  1215.     jnz    @@aritherror
  1216.     jmp    next_pc
  1217. @@aritherror:
  1218.     jmp    sch_err
  1219.  
  1220. @@overflow:
  1221.     mov    ax, 8000h        ; it could only be (- #\h8000)
  1222.     xor    dx, dx
  1223. in_enlargelong:
  1224.     save    <si>
  1225.     add    di, OFFSET regs
  1226.     call    enlarge C, di, ax, dx    ; create bignum
  1227.     jmp    next_pc
  1228. ENDP    minus
  1229.  
  1230. ;************************************************************************
  1231. ;*    Support for absolute value    (abs n)                *
  1232. ;************************************************************************
  1233. PROC    sabs
  1234.     get1op
  1235.     mov    di, ax
  1236.     cmp    [regs+di.page], SPECFIX*2
  1237.     jne    @@notfix
  1238.     mov    ax, [regs+di.disp]
  1239.     or    ax, ax            ; how's it relate to zero?
  1240.     js    in_minus
  1241.     jmp    next
  1242. @@notfix:
  1243.     mov    dx, ABS_OP
  1244.     jmp    in_arith
  1245. ENDP    sabs
  1246.  
  1247. ;************************************************************************
  1248. ;*        Macro support for out-of-line calls to Borland C    *
  1249. ;************************************************************************
  1250. MACRO    TESTARG
  1251.     or    ax, ax            ; was error detected?
  1252.     jl    @@error
  1253.     jmp    next_pc
  1254. @@error:
  1255.     jmp    sch_err
  1256. ENDM
  1257.  
  1258. ;************************************************************************
  1259. ; Convert number to fixnum (toward NEARest integer)    ROUND    reg    *
  1260. ;************************************************************************
  1261. PROC    sround
  1262.     call    get1parm
  1263.     call    around C, ax
  1264.     TESTARG
  1265. ENDP
  1266.  
  1267. ;************************************************************************
  1268. ; Convert number to fixnum (toward - infinity)        FLOOR    reg    *
  1269. ;************************************************************************
  1270. PROC    sfloor
  1271.     call    get1parm
  1272.     call    afloor C, ax
  1273.     TESTARG
  1274. ENDP
  1275.  
  1276. ;************************************************************************
  1277. ; Convert number to fixnum (toward + infinity)        CEILING    reg    *
  1278. ;************************************************************************
  1279. PROC    sceiling
  1280.     call    get1parm
  1281.     call    aceiling C, ax
  1282.     TESTARG
  1283. ENDP
  1284.  
  1285. ;************************************************************************
  1286. ; Convert number to fixnum (toward zero)        TRUNCATE reg    *
  1287. ;************************************************************************
  1288. PROC    struncat
  1289.     call    get1parm
  1290.     call    atruncate C, ax
  1291.     TESTARG
  1292. ENDP
  1293.  
  1294. ;************************************************************************
  1295. ; Convert number to fixnum                FLOAT reg    *
  1296. ;************************************************************************
  1297. PROC    float
  1298.     call    get1parm
  1299.     call    sfloat C, ax
  1300.     TESTARG
  1301. ENDP
  1302.  
  1303. ;************************************************************************
  1304. ;* Support for string->symbol            (string->symbol    dest)    *
  1305. ;************************************************************************
  1306. PROC    str2sym
  1307.     call    get1parm
  1308.     call    str_2_sym C, ax
  1309.     TESTARG
  1310. ENDP
  1311.  
  1312. ;************************************************************************
  1313. ;* string->uninterned-symbol        (string->uninterned-symbol dest)*
  1314. ;************************************************************************
  1315. PROC    str2usym
  1316.     call    get1parm
  1317.     call    str_2_usym C, ax
  1318.     TESTARG
  1319. ENDP
  1320.  
  1321. ;************************************************************************
  1322. ;* Support for symbol->string            (symbol->string    dest)    *
  1323. ;************************************************************************
  1324. PROC    sym2str
  1325.     call    get1parm
  1326.     call    sym_2_str C, ax
  1327.     TESTARG
  1328. ENDP
  1329.  
  1330. ;************************************************************************
  1331. ;*             Support for read-line                *
  1332. ;************************************************************************
  1333. PROC    srd_line
  1334.     get1op
  1335.     save    <si>
  1336.     add    ax, OFFSET regs
  1337.     push    ax
  1338.     xor    bx, bx
  1339.     call    get_port C, ax, bx    ; get the port object
  1340.     test    ax, ax            ; error returned?
  1341.     pop    cx            ; restore main reg
  1342.     jnz    @@error
  1343.     call    sread_ln C, cx, [tmp_reg.page], [tmp_reg.disp]
  1344.     jmp    next_pc
  1345. @@error:
  1346.     lea    bx, [@@msg]
  1347.     jmp    src_err
  1348. DATASEG
  1349. @@msg    DB    "READ-LINE", 0
  1350. CODESEG
  1351. ENDP    srd_line
  1352.  
  1353. ;************************************************************************
  1354. ;*             Support for read-atom                *
  1355. ;************************************************************************
  1356. PROC    srd_atom
  1357.     get1op
  1358.     save    <si>
  1359.     add    ax, OFFSET regs
  1360.     push    ax
  1361.     xor    bx, bx
  1362.     call    get_port C, ax, bx    ; get the port object
  1363.     test    ax, ax            ; error returned?
  1364.     pop    cx
  1365.     jnz    @@error
  1366.     call    sread_atom C, cx, [tmp_reg.page], [tmp_reg.disp]
  1367.     jmp    next_pc
  1368. @@error:
  1369.     lea    bx, [@@msg]
  1370.     jmp    src_err
  1371. DATASEG
  1372. @@msg    DB    "READ-ATOM", 0
  1373. CODESEG
  1374. ENDP    srd_atom
  1375.  
  1376. ;************************************************************************
  1377. ;* Support for push_char                        *
  1378. ;************************************************************************
  1379. PROC    unread_char
  1380.     get1op
  1381.     save    <si>
  1382.     add    ax, OFFSET regs
  1383.     xor    cx, cx
  1384.     call    get_port C, ax, cx
  1385.     test    ax,ax            ; check return status
  1386.     jnz    @@error
  1387.  
  1388.     call    ssetadr C, [tmp_reg.page], [tmp_reg.disp]
  1389.     call    pushchar C
  1390.     jmp    next_pc
  1391.  
  1392. @@error:                ; Wrong port object, display error
  1393.     lea    bx, [@@msg]
  1394.     jmp    src_err
  1395.  
  1396. DATASEG
  1397. @@msg    DB    "UNREAD-CHAR", 0
  1398. CODESEG
  1399. ENDP    unread_char
  1400.  
  1401. ;************************************************************************
  1402. ;* Support for read-char-ready?                        *
  1403. ;************************************************************************
  1404. PROC    rd_char_rdy
  1405.     get1op
  1406.     save    <si>
  1407.     add    ax, OFFSET regs        ; compute register address
  1408.     mov    di, ax
  1409.     xor    cx, cx
  1410.     call    get_port C, ax, cx
  1411.     test    ax,ax            ; check return status
  1412.     jz    @@portok
  1413.     jmp    @@error
  1414.  
  1415. @@portok:
  1416.     mov    [(REG di).page], SPECCHAR*2 ; prepare to return a char
  1417.     mov    si, [tmp_reg.disp]
  1418.     mov    bx, [tmp_reg.page]
  1419.     ldpage    es, bx
  1420.     mov    bx, [(PORTDEF es:si).bufpos] ; input buffer starting position
  1421.     cmp    bx, [(PORTDEF es:si).bufend] ; compare with ending position
  1422.     jge    @@endbuffer
  1423.     xor    ah, ah
  1424.     mov    al, [(PORTDEF es:si+bx).buffer] ; get the character
  1425. @@testchar:
  1426.     cmp    al, CTRL_Z        ; End-Of-File ?
  1427.     jne    @@return
  1428.     mov    bx, [(PORTDEF es:si).pflags]
  1429.     and    bx, PORT_BINARY        ; binary file?
  1430.     jnz    @@return
  1431. @@eof:
  1432.     mov    [(REG di).page], EOF_PAGE*2 ; return eof character
  1433.     mov    [(REG di).disp], EOF_DISP
  1434.     jmp    next_pc
  1435.  
  1436. @@return:
  1437.     mov    [(REG di).disp], ax ; return the character
  1438.     jmp    next_pc
  1439.  
  1440. @@endbuffer:
  1441.     mov    ax, [(PORTDEF es:si).pflags]
  1442.     test    ax, PORT_TYPE        ; window?
  1443.     jnz    @@nowindow
  1444.     call    GETCHready C        ; any character?
  1445.     test    ax, ax
  1446.     jz    @@nochar
  1447.     mov    ah, 0            ; yes
  1448.     jmp    @@return
  1449.  
  1450. @@nochar:                ; no character available. return '()
  1451.     mov    [(REG di).page], NIL_PAGE
  1452.     mov    [(REG di).disp], NIL_DISP
  1453.     jmp    next_pc
  1454.  
  1455. @@nowindow:
  1456.     test    ax, READ_OPEN        ; open?
  1457.     jz    @@nochar
  1458.     call    ssetadr C, [tmp_reg.page], [tmp_reg.disp]
  1459.     call    take_ch    C        ; get one character
  1460.     cmp    ax, 256            ; eof?
  1461.     je    @@eof
  1462.     push    ax
  1463.     call    pushchar C        ; no, put it back
  1464.     pop    ax
  1465.     jmp    @@return
  1466.  
  1467. @@error:                ; Wrong port object, display error
  1468.     lea    bx, [@@msg]
  1469.     jmp    src_err
  1470.  
  1471. DATASEG
  1472. @@msg    DB    "CHAR-READY?", 0
  1473. CODESEG
  1474. ENDP    rd_char_rdy
  1475.  
  1476. ;************************************************************************
  1477. ;* Support for read-char                        *
  1478. ;************************************************************************
  1479. PROC    read_char
  1480.     get1op
  1481.     save    <si>
  1482.     add    ax, OFFSET regs        ; compute register address
  1483.     mov    di,ax
  1484.     xor    cx,cx
  1485.     call    get_port C, ax, cx
  1486.     test    ax,ax            ; check return status
  1487.     jz    @@portok
  1488.     jmp    @@error
  1489.  
  1490. @@portok:
  1491.     mov    [(REG di).page], SPECCHAR*2
  1492.     mov    bx, [tmp_reg.page]
  1493.     ldpage    es, bx
  1494.     mov    si, [tmp_reg.disp]
  1495.     mov    ax, [(PORTDEF es:si).pflags] ; get port flags
  1496.     test    ax, PORT_TYPE        ; window object?
  1497.     jnz    @@readchar
  1498.     mov    bx, [(PORTDEF es:si).bufpos] ; input buffer starting position
  1499.     cmp    bx, [(PORTDEF es:si).bufend] ; compare with ending position
  1500.     jl    @@readchar
  1501.     mov    cx, [(PORTDEF es:si).curline]
  1502.     add    cx, [(PORTDEF es:si).ulline]
  1503.     mov    dx, [(PORTDEF es:si).curcol]
  1504.     add    dx, [(PORTDEF es:si).ulcol]
  1505.     push    ax
  1506.     mov    ax, [(PORTDEF es:si).text]
  1507.     mov    [t_attrib], ax
  1508.     pop    ax
  1509.  
  1510.     call    zputcur C, cx, dx    ; cursor position
  1511.     call    zcuron C        ; cursor on
  1512.     call    GETCH C            ; get character
  1513.     mov    ah, 0
  1514.     mov    [(REG di).disp], ax
  1515.     mov    bx, [tmp_reg.page]
  1516.     ldpage    es, bx
  1517.     mov    [(PORTDEF es:si).buffer], al ; store in port object
  1518.     call    zcuroff    C        ; cursor off
  1519.     mov    bx,1
  1520.     mov    [(PORTDEF es:si).bufpos], bx
  1521.     mov    [(PORTDEF es:si).bufend], bx
  1522.     jmp    next_pc
  1523.  
  1524. @@readchar:
  1525.     call    ssetadr    C, [tmp_reg.page],[tmp_reg.disp] ; set port address
  1526.     call    take_ch    C        ; take one character
  1527.     cmp    ax, 256            ; eof?
  1528.     je    @@eof
  1529.     mov    [(REG di).disp], ax ; return the character
  1530.     jmp    next_pc
  1531. @@eof:
  1532.     mov    [(REG di).page], EOF_PAGE*2 ; return eof character
  1533.     mov    [(REG di).disp], EOF_DISP
  1534.     jmp    next_pc
  1535.  
  1536. @@error:
  1537.     lea    bx, [@@msg]        ; address of error message
  1538.     jmp    src_err
  1539.  
  1540. DATASEG
  1541. @@msg    DB    "READ-CHAR", 0
  1542. CODESEG
  1543. ENDP    read_char
  1544.  
  1545. ;************************************************************************
  1546. ;* Support for fast load                (fasl filename)    *
  1547. ;************************************************************************
  1548. PROC    sfasl
  1549.     call    get1parm
  1550.     call    fasl C, ax
  1551.     TESTARG
  1552. ENDP
  1553.  
  1554. ;************************************************************************
  1555. ;* Support for %push-history             (%push-history string)    *
  1556. ;************************************************************************
  1557. PROC    push_hist
  1558.     call    get1parm
  1559.     call    pushhistory C, ax
  1560.     TESTARG
  1561. ENDP
  1562.  
  1563. ;************************************************************************
  1564. ;* Support for %get-history            (%get-history string)    *
  1565. ;************************************************************************
  1566. PROC    get_hist
  1567.     call    get1parm
  1568.     call    gethistory C, ax
  1569.     TESTARG
  1570. ENDP
  1571.  
  1572. ;************************************************************************
  1573. ;* Support for clear-history                (clear-history)    *
  1574. ;************************************************************************
  1575. PROC    clr_hist
  1576.     lea    ax, [history]
  1577.     mov    [histpos], ax
  1578.     mov    [histend], ax
  1579.     jmp    next
  1580. ENDP
  1581.  
  1582. ;************************************************************************
  1583. ;* Support for prop-list                (prop-list name)*
  1584. ;************************************************************************
  1585. PROC    proplist
  1586.     call    get1parm
  1587.     call    prop_list C, ax
  1588.     TESTARG
  1589. ENDP
  1590.  
  1591. ;************************************************************************
  1592. ;* Support for random                    (random seed)    *
  1593. ;************************************************************************
  1594. PROC    random
  1595.     call    get1parm
  1596.     call    srandom C, ax
  1597.     jmp    next_pc
  1598. ENDP
  1599.  
  1600. ;************************************************************************
  1601. ;* Support for clear-window            (clear-window dest)    *
  1602. ;************************************************************************
  1603. PROC    clr_wind
  1604.     call    get1parm
  1605.     call    clear_window C, ax
  1606.     TESTARG
  1607. ENDP
  1608.  
  1609. ;************************************************************************
  1610. ;* Support for close-port            (close-port port)    *
  1611. ;************************************************************************
  1612. PROC    p_close
  1613.     call    get1parm
  1614.     call    spclose C, ax
  1615.     TESTARG
  1616. ENDP
  1617.  
  1618. ;************************************************************************
  1619. ;* Support for %start-timer             (%start-timer #-ticks) *
  1620. ;************************************************************************
  1621. PROC    set_tim
  1622.     call    get1parm
  1623.     call    cset_tim C, ax
  1624.     TESTARG
  1625. ENDP
  1626.  
  1627. ;************************************************************************
  1628. ;* Support for %stop-timer                (%stop-timer)    *
  1629. ;************************************************************************
  1630. PROC    rst_tim
  1631.     call    get1parm
  1632.     call    crst_tim C, ax
  1633.     TESTARG
  1634. ENDP
  1635.  
  1636. ;************************************************************************
  1637. ;* Support for STRING-LENGTH            (STRING-LENGTH    STRING) *
  1638. ;************************************************************************
  1639. PROC    str_lng
  1640.     call    get1parm
  1641.     call    st_len C, ax
  1642.     TESTARG
  1643. ENDP
  1644.  
  1645. ;************************************************************************
  1646. ;*        Support for Object-Hash, -Unhash            *
  1647. ;************************************************************************
  1648. PROC    obj_hash
  1649.     get1op
  1650.     save    <si>
  1651.     add    ax, OFFSET regs
  1652.     call    objhash C, ax
  1653.     jmp    next_pc
  1654. ENDP    obj_hash
  1655.  
  1656. PROC    obj_unhs
  1657.     get1op
  1658.     save    <si>
  1659.     add    ax, OFFSET regs
  1660.     call    objunhash C, ax
  1661.     jmp    next_pc
  1662. ENDP    obj_unhs
  1663.  
  1664. ;************************************************************************
  1665. ;* Support for REIFY-STACK            (REIFY-STACK index)    *
  1666. ;************************************************************************
  1667. PROC    reify_s
  1668.     xor    cx, cx            ; Read subfunction
  1669.     call    get1parm
  1670. in_reify_s:
  1671.     call    reif_stk C, ax, bx, cx
  1672.     TESTARG
  1673. ENDP
  1674.  
  1675. ;************************************************************************
  1676. ;* Support for get-prop                (get-prop name prop)    *
  1677. ;************************************************************************
  1678. PROC    getprop
  1679.     call    get2parm
  1680.     call    get_prop C, ax, bx
  1681.     jmp    next_pc
  1682. ENDP
  1683.  
  1684. ;************************************************************************
  1685. ;* Support for rem-prop                (rem-prop name prop)    *
  1686. ;************************************************************************
  1687. PROC    remprop
  1688.     call    get2parm
  1689.     call    rem_prop C, ax, bx
  1690.     jmp    next_pc
  1691. ENDP
  1692.  
  1693. ;************************************************************************
  1694. ;* Support for open-port            (open port mode)    *
  1695. ;************************************************************************
  1696. PROC    p_open
  1697.     call    get2parm
  1698.     call    spopen C, ax, bx
  1699.     TESTARG
  1700. ENDP
  1701.  
  1702. ;************************************************************************
  1703. ;* Support for REIFY-STACK!        (REIFY-STACK! index value)    *
  1704. ;************************************************************************
  1705. PROC    reify_sb
  1706.     call    get2parm        ; Get parameters
  1707.     mov    cx, 1            ; Write subfunction
  1708.     jmp    in_reify_s
  1709. ENDP
  1710.  
  1711. ;************************************************************************
  1712. ;* Support for APPEND                (APPEND list obj)    *
  1713. ;************************************************************************
  1714. PROC    append
  1715.     call    get2parm
  1716.     call    sappend C, ax, bx
  1717.     TESTARG
  1718. ENDP
  1719.  
  1720. ;************************************************************************
  1721. ;* Support for put-prop            (put-prop name value prop)    *
  1722. ;************************************************************************
  1723. PROC    putprop
  1724.     call    get3parm
  1725.     call    put_prop C, cx, ax, bx
  1726.     TESTARG
  1727. ENDP
  1728.  
  1729. ;************************************************************************
  1730. ;* Substring (substring string position length)    SUBSTR    str,pos,len    *
  1731. ;************************************************************************
  1732. PROC    substring
  1733.     call    get3parm
  1734.     call    ssubstr C, cx, ax, bx
  1735.     TESTARG
  1736. ENDP
  1737.  
  1738. ;************************************************************************
  1739. ;* Support for set-window-attr    (get-window-attribute wind attr val)    *
  1740. ;************************************************************************
  1741. PROC    set_w_at
  1742.     call    get3parm
  1743.     call    set_window_attribute C, cx, ax, bx
  1744.     TESTARG
  1745. ENDP
  1746.  
  1747. ;************************************************************************
  1748. ;* Interface to set file position (set-file-position! port chunk# BYTEs)*
  1749. ;************************************************************************
  1750. PROC    sfpos
  1751.     call    get3parm
  1752.     call    set_pos C, cx, ax, bx
  1753.     TESTARG
  1754. ENDP
  1755.  
  1756. ;************************************************************************
  1757. ;* Support for make-port        (make-port typesymbol source)    *
  1758. ;************************************************************************
  1759. PROC    port_make
  1760.     call    get2parm
  1761.     call    make_port C, ax, bx
  1762.     TESTARG
  1763. ENDP
  1764.  
  1765. ;************************************************************************
  1766. ;* Support for %port-get-attribute     (%port-get-attribute port attr)    *
  1767. ;************************************************************************
  1768. PROC    port_get
  1769.     call    get2parm
  1770.     call    port_get_attribute C, ax, bx
  1771.     TESTARG
  1772. ENDP
  1773.  
  1774. ;************************************************************************
  1775. ;* Support for %port-set-attribute! (%port-set-attribute! port attr val)*
  1776. ;************************************************************************
  1777. PROC    port_set
  1778.     call    get3parm
  1779.     call    port_set_attribute C, cx, ax, bx
  1780.     TESTARG
  1781. ENDP
  1782.  
  1783. ;************************************************************************
  1784. ;* Support for %read-char                   (%read-char port)    *
  1785. ;************************************************************************
  1786. PROC    port_char
  1787.     call    get1parm
  1788.     call    port_read_char C, ax
  1789.     TESTARG
  1790. ENDP
  1791.  
  1792. ;************************************************************************
  1793. ;* Support for %read-line                   (%read-line port)    *
  1794. ;************************************************************************
  1795. PROC    port_line
  1796.     call    get1parm
  1797.     call    port_read_line C, ax
  1798.     TESTARG
  1799. ENDP
  1800.  
  1801. ;************************************************************************
  1802. ;* Support for %char-ready?                 (%char-ready? port)    *
  1803. ;************************************************************************
  1804. PROC    port_ready
  1805.     call    get1parm
  1806.     call    port_char_ready C, ax
  1807.     TESTARG
  1808. ENDP
  1809.  
  1810. ;************************************************************************
  1811. ;* Support for %peek-char                   (%peek-char port)    *
  1812. ;************************************************************************
  1813. PROC    port_peek
  1814.     call    get1parm
  1815.     call    port_peek_char C, ax
  1816.     TESTARG
  1817. ENDP
  1818.  
  1819. ;************************************************************************
  1820. ;* Support for %str-str   (%str-str str start end match direction case) *
  1821. ;************************************************************************
  1822. PROC    str_str
  1823.     call    get4parm
  1824.     push    ax bx
  1825.     call    get2parm
  1826.     mov    di, ax            ; DIrection
  1827.     mov    si, bx            ; senSItivity
  1828.     mov    di, [(REG di).page]    ; #f means forward
  1829.     mov    si, [(REG si).page]    ; #f means insensitive
  1830.     pop    bx ax
  1831.     call    str_srch_str C, cx, dx, ax, bx, di, si
  1832.     TESTARG
  1833. ENDP
  1834.  
  1835. ;************************************************************************
  1836. ;* Support for subst.-find-prev-char-in-set (... str start end charset) *
  1837. ;************************************************************************
  1838. PROC    srch_pr
  1839.     mov    di, -1            ; set direction backward
  1840.     jmp search_char
  1841. ENDP
  1842.  
  1843. ;************************************************************************
  1844. ;* Support for subst.-find-next-char-in-set (... str start end charset) *
  1845. ;************************************************************************
  1846. PROC    srch_nx
  1847.     xor    di, di            ; set direction forward
  1848. search_char:
  1849.     call    get4parm
  1850.     call    srch_str C, cx, dx, ax, bx, di
  1851.     TESTARG
  1852. ENDP
  1853.  
  1854. ;************************************************************************
  1855. ;*                             al  ah    al    *
  1856. ;* Support for "reification"            (%reify     obj index)    *
  1857. ;*                        (%reify! obj index val) *
  1858. ;************************************************************************
  1859. PROC    sreifyb
  1860.     mov    cx, 1            ; set flag for "store" operation
  1861.     jmp    in_sreify
  1862. ENDP    sreifyb
  1863. PROC    sreify
  1864.     xor    cx, cx            ; set flag for "load" operation
  1865. in_sreify:
  1866.     get2op
  1867.     xor    bx, bx
  1868.     mov    bl, al
  1869.     lea    di, [regs+bx]
  1870.     mov    bl, ah            ; copy index's register number and
  1871.     add    bx, OFFSET regs        ; compute index register's address
  1872.     or    cx, cx            ; is this a load or a store?
  1873.     jz    @@load
  1874.     xor    ax, ax
  1875.     get1op
  1876.     add    ax, OFFSET regs
  1877. @@load:
  1878.     save    <si>
  1879.     call    reify C, cx, di, bx, ax
  1880.     or    ax, ax            ; test result of reification request
  1881.     jnz    @@error
  1882.     jmp    next_pc
  1883. @@error:
  1884.     jmp    sch_err
  1885. ENDP    sreify
  1886.  
  1887. ;************************************************************************
  1888. ;* Macro definition - Interpreter support for binary operations        *
  1889. ;*                                    *
  1890. ;* Purpose:    To generate interpreter support for operations of the    *
  1891. ;*        form:                            *
  1892. ;*                OP        dest,src        *
  1893. ;*        where:                            *
  1894. ;*            destination reg <- destination reg OP source reg*
  1895. ;************************************************************************
  1896. MACRO    bin_op
  1897.     get2op
  1898.     mov    bl, al
  1899.     mov    di, bx
  1900.     mov    al, [regs+di.bpage]    ; test to see if destination's FIX
  1901.     cmp    al, SPECFIX*2
  1902.     jne    @@ool
  1903.     mov    bl, ah            ; copy source register number
  1904.     cmp    al, [regs+bx.bpage]    ; is second operand also a fixnum?
  1905.     jne    @@ool
  1906.     mov    bx, [regs+bx.disp]    ; load source (second) operand
  1907.     mov    ax, [regs+di.disp]    ; load destination (first) operand
  1908. ENDM
  1909.  
  1910. MACRO    bin_ret
  1911.     mov    [regs+di.disp], ax    ; store result into destination register
  1912. @@tonext:
  1913.     jmp    next
  1914. ENDM
  1915.  
  1916. ;************************************************************************
  1917. ; Addition (+ obj1 obj2)    ADDOP    dest,src            *
  1918. ;************************************************************************
  1919. PROC    addproc
  1920.     bin_op
  1921.     add    ax, bx
  1922.     jo    add_overflow
  1923.     bin_ret
  1924. sub_overflow:
  1925.     cmc                ; complement the carry bit for subtract
  1926. add_overflow:
  1927.     mov    dx, 0            ; make a long
  1928.     sbb    dx, 0
  1929.     jmp    in_enlargelong        ; convert to bignum
  1930. @@ool:
  1931.     mov    dx, ADD_OP        ; load operation type
  1932.  
  1933. ;    General arithmetic support for non-integer binary arithmetic operations
  1934. ;    Registers at this point:    ah - source register number
  1935. ;                    bh - (zero)
  1936. ;                    dx - arithmetic sub-opcode (operation type)
  1937. ;                    di - destination register number
  1938.  
  1939. bin_ool:
  1940.     save    <si>
  1941.     mov    bl, ah            ; copy source register number
  1942.     add    bx, OFFSET regs
  1943.     add    di, OFFSET regs
  1944.     call    arith2 C, dx, di, bx
  1945.     or    ax, ax            ; error encountered?
  1946.     jnz    @@error
  1947.     jmp    next_pc
  1948. @@error:
  1949.     jmp    sch_err
  1950. ENDP    addproc
  1951.  
  1952. ;************************************************************************
  1953. ;* Subtraction (- obj1 obj2)                SUB    dest,src*
  1954. ;************************************************************************
  1955. PROC    subproc
  1956.     bin_op
  1957.     sub    ax, bx
  1958.     jo    @@overflow
  1959.     bin_ret
  1960. @@ool:
  1961.     mov    dx, SUB_OP
  1962.     jmp    bin_ool
  1963.  
  1964. @@overflow:
  1965.     mov    dx, 0            ; make a long
  1966.     adc    dx, 0ffffh
  1967.     jmp    in_enlargelong        ; convert to bignum
  1968. ENDP    subproc
  1969.  
  1970. ;************************************************************************
  1971. ;* Multiplication (* obj1 obj2)            MUL    dest,src    *
  1972. ;************************************************************************
  1973. PROC    mulproc
  1974.     bin_op
  1975.     imul    bx
  1976.     jo    mul_overflow
  1977.     bin_ret
  1978. @@ool:
  1979.     mov    dx, MUL_OP
  1980.     jmp    bin_ool
  1981. mul_overflow:
  1982.     jmp    in_enlargelong
  1983. ENDP    mulproc
  1984.  
  1985. ;************************************************************************
  1986. ;* Division (/ obj1 obj2)                DIV    dest,src*
  1987. ;************************************************************************
  1988. PROC    divproc
  1989.     bin_op
  1990.     or    bx, bx            ; is the divisor zero?
  1991.     jz    @@zero
  1992.     cwd                ; convert dividend to a doubleword
  1993.     idiv    bx            ; divide the two operands
  1994.     or    dx, dx            ; is remainder zero?
  1995.     jne    @@fraction
  1996.     bin_ret
  1997. @@ool:
  1998.     mov    dx, DIV_OP
  1999.     jmp    bin_ool
  2000. divzero:
  2001. @@zero:
  2002.     lea    bx, [@@msg]
  2003. DATASEG
  2004. @@msg    DB    "/", 0
  2005. CODESEG
  2006. in_divproc:
  2007.     sub    si, 3            ; back up location pointer to start of inst.
  2008.     call    disassemble C, bx, si    ; "disassemble" the instruction
  2009.     mov    ax, 1
  2010.     mov    bx, ZERO_DIVIDE_ERROR
  2011.     call    set_numeric_error C, ax, bx, [tmp_adr]
  2012.     jmp    sch_err
  2013. @@fraction:
  2014.     add    di, OFFSET regs
  2015.     push    es            ; saves es over C call
  2016.     call    sfloat C, di        ; convert destination op to flonum
  2017.     pop    es
  2018.     sub    si, 2            ; back up the location pointer
  2019.     xor    bx, bx
  2020.     jmp    divproc            ; re-execute div in floating point
  2021. ENDP    divproc
  2022.  
  2023. ;************************************************************************
  2024. ;* Integer Division (quotient obj1 obj2)    QUOTIENT dest,src    *
  2025. ;************************************************************************
  2026. PROC    quotient
  2027.     bin_op
  2028.     or    bx, bx
  2029.     jz    @@zero
  2030.     cwd                ; convert dividend to a doubleword
  2031.     idiv    bx
  2032.     bin_ret
  2033. @@ool:
  2034.     mov    dx, QUOT_OP
  2035.     jmp    bin_ool
  2036. @@zero:
  2037.     lea    bx, [@@msg]
  2038. DATASEG
  2039. @@msg    DB    "QUOTIENT", 0
  2040. CODESEG
  2041.     jmp    in_divproc
  2042. ENDP    quotient
  2043.  
  2044. ;************************************************************************
  2045. ;* Remainder (remainder obj1 obj2)        REMAINDER dest,src    *
  2046. ;************************************************************************
  2047. PROC    remainder
  2048.     bin_op
  2049.     or    bx, bx
  2050.     jz    @@zero
  2051.     cwd                ; convert dividend to a doubleword
  2052.     idiv    bx
  2053.     mov    ax, dx
  2054.     bin_ret
  2055. @@zero:
  2056.     lea    bx, [@@msg]
  2057. DATASEG
  2058. @@msg    DB    "REMAINDER", 0
  2059. CODESEG
  2060.     jmp    in_divproc
  2061. @@ool:
  2062.     mov    dx, REM_OP
  2063.     jmp    bin_ool
  2064. ENDP    remainder
  2065.  
  2066. ;************************************************************************
  2067. ;* Integer Division (divide obj1 obj2)            DIVIDE dest,src    *
  2068. ;************************************************************************
  2069. PROC    divide
  2070.     bin_op
  2071.     or    bx, bx
  2072.     jz    @@zero
  2073.     cwd                ; convert dividend to a doubleword
  2074.     mov    cx, dx            ; save sign of dividend
  2075.     idiv    bx
  2076.     or    dx, dx            ; if no remainder, ok.
  2077.     jz    @@ok
  2078.     xor    bx, cx            ; compare signs of dividend & divisor
  2079.     and    bx, 8000h
  2080.     jz    @@ok
  2081.     dec    ax
  2082. @@ok:
  2083.     bin_ret
  2084.  
  2085. @@ool:
  2086.     mov    dx, DIVIDE_OP
  2087.     jmp    bin_ool
  2088.  
  2089. @@zero:
  2090.     lea    bx, [@@msg]
  2091. DATASEG
  2092. @@msg    DB    "DIVIDE", 0
  2093. CODESEG
  2094.     jmp    in_divproc
  2095. ENDP    divide
  2096.  
  2097. ;************************************************************************
  2098. ;* Modulo (modulo obj1 obj2)                MODULO dest,src    *
  2099. ;************************************************************************
  2100. PROC    modulo
  2101.     bin_op
  2102.     or    bx, bx
  2103.     jz    @@zero
  2104.     cwd                ; convert dividend to a doubleword
  2105.     idiv    bx
  2106.     mov    ax, dx
  2107.     xor    dx, bx            ; compare signs of rem. and divisor
  2108.     and    dx, 8000h
  2109.     jz    @@ok
  2110.     or    ax, ax            ; don't fix up 0
  2111.     jz    @@ok
  2112.     add    ax, bx
  2113. @@ok:
  2114.     bin_ret
  2115.  
  2116. @@zero:
  2117.     lea    bx, [@@msg]
  2118. DATASEG
  2119. @@msg    DB    "MODULO", 0
  2120. CODESEG
  2121.     jmp    in_divproc
  2122. @@ool:
  2123.     mov    dx, MOD_OP
  2124.     jmp    bin_ool
  2125. ENDP    modulo
  2126.  
  2127. ;************************************************************************
  2128. ;* Maximum value (max obj1 obj2)            MAX    dest,src*
  2129. ;************************************************************************
  2130. PROC    maximum
  2131.     bin_op
  2132.     cmp    ax, bx
  2133.     jge    @@tonext
  2134.     mov    ax, bx            ; copy the source operand to ax
  2135.     bin_ret
  2136. @@ool:
  2137.     mov    dx, GE_OP        ; load operation type
  2138. max_ool:
  2139.     save    <si>
  2140.     mov    bl, ah            ; copy source register number
  2141.     add    bx, OFFSET regs
  2142.     add    di, OFFSET regs
  2143.     push    bx di
  2144.     call    arith2 C, dx, di, bx
  2145.     pop    di bx
  2146.     or    ax, ax            ; what was the result of the comparison?
  2147.     jl    @@error
  2148.     jnz    @@done
  2149.     mov    ax, [(REG bx).disp]    ; copy source operand into the destination
  2150.     mov    bl, [(REG bx).bpage]
  2151.     mov    [(REG di).disp], ax
  2152.     mov    [(REG di).bpage], bl
  2153. max_done:
  2154. @@done:
  2155.     jmp    next_pc
  2156. @@error:
  2157.     jmp    sch_err
  2158. ENDP    maximum
  2159.  
  2160. ;************************************************************************
  2161. ;* Minimum value (min obj1 obj2)            MIN    dest,src*
  2162. ;************************************************************************
  2163. PROC    minimum
  2164.     bin_op
  2165.     cmp    ax, bx
  2166.     jle    @@tonext
  2167.     mov    ax, bx            ; copy the source operand to ax
  2168.     bin_ret
  2169. @@ool:
  2170.     mov    dx, LE_OP
  2171.     jmp    max_ool
  2172. ENDP    minimum
  2173.  
  2174. ;************************************************************************
  2175. ;* (bitwise-xor obj1 obj2)                XOR    dest,src*
  2176. ;************************************************************************
  2177. PROC    b_xor
  2178.     bin_op
  2179.     xor    ax, bx
  2180.     bin_ret
  2181. @@ool:
  2182.     mov    dx, XOR_OP
  2183.     jmp    bin_ool
  2184. ENDP    b_xor
  2185.  
  2186. ;************************************************************************
  2187. ;* (bitwise-and obj1 obj2)                AND    dest,src*
  2188. ;************************************************************************
  2189. PROC    b_and
  2190.     bin_op
  2191.     and    ax, bx
  2192.     bin_ret
  2193. @@ool:
  2194.     mov    dx, AND_OP
  2195.     jmp    bin_ool
  2196. ENDP    b_and
  2197.  
  2198. ;************************************************************************
  2199. ;* (bitwise-or obj1 obj2)                OR    dest,src*
  2200. ;************************************************************************
  2201. PROC    b_or
  2202.     bin_op
  2203.     or    ax, bx
  2204.     bin_ret
  2205. @@ool:
  2206.     mov    dx, OR_OP
  2207.     jmp    bin_ool
  2208. ENDP    b_or
  2209.  
  2210. ;************************************************************************
  2211. ;* Macro definition - Interpreter support for immediate operations    *
  2212. ;*                                    *
  2213. ;* Purpose:    To generate interpreter support for operations of the    *
  2214. ;*        form:                            *
  2215. ;*                OP        dest,immediate            *
  2216. ;*        where:                            *
  2217. ;*            destination reg <- destination reg OP immediate    *
  2218. ;************************************************************************
  2219. MACRO    immed_op
  2220.     get2op
  2221.     mov    bl, al
  2222.     mov    di, bx
  2223.     mov    al, ah            ; sign extend immediate operand
  2224.     cbw
  2225.     cmp    [regs+di.bpage], SPECFIX*2 ; dest operand a fixnum?
  2226.     jne    @@ool
  2227.     mov    bx, ax            ; move immediate operand to bx
  2228.     mov    ax, [regs+di.disp]    ; load destination (first) operand
  2229. ENDM
  2230.  
  2231. ;************************************************************************
  2232. ;* Add immediate                    ADDI    reg,val *
  2233. ;************************************************************************
  2234. PROC    addi
  2235.     immed_op
  2236.     add    ax, bx
  2237.     jo    addi_overflow
  2238.     bin_ret
  2239. addi_overflow:
  2240.     jmp    add_overflow
  2241. @@ool:
  2242.     mov    dx, ADD_OP        ; load operation type
  2243.  
  2244. ;    General arithmetic support for non-integer immediate operations
  2245. ;    Registers at this point:    ax - immediate value
  2246. ;                    dx - arithmetic sub-opcode (operation type)
  2247. ;                    di - destination register number
  2248.  
  2249. bini_ool:
  2250.     save    <si>
  2251.     add    di, OFFSET regs
  2252.     mov    [tmp_reg.disp], ax
  2253.     mov    [tmp_reg.page], SPECFIX*2
  2254.     call    arith2 C, dx, di, [tmp_adr]
  2255.     or    ax, ax
  2256.     jne    @@error
  2257.     jmp    next_pc
  2258. @@error:
  2259.     jmp    sch_err
  2260. ENDP    addi
  2261.  
  2262. ;************************************************************************
  2263. ;* Multiply Immediate                    MULI    reg,val *
  2264. ;************************************************************************
  2265. PROC    muli
  2266.     immed_op
  2267.     imul    bx
  2268.     jo    muli_overflow
  2269.     bin_ret
  2270. muli_overflow:
  2271.     jmp    mul_overflow
  2272. @@ool:
  2273.     mov    dx, MUL_OP
  2274.     jmp    bini_ool
  2275. ENDP    muli
  2276.  
  2277. ;************************************************************************
  2278. ;* Divide Immediate                    DIVI    reg,val *
  2279. ;************************************************************************
  2280. PROC    divi
  2281.     immed_op
  2282.     or    bx, bx            ; is the divisor zero?
  2283.     jz    @@zero
  2284.     cwd                ; convert dividend to a doubleword
  2285.     idiv    bx
  2286.     or    dx, dx            ; is remainder zero?
  2287.     jnz    @@fraction
  2288.     bin_ret
  2289. @@zero:
  2290.     jmp    divzero
  2291. @@fraction:
  2292.     add    di, OFFSET regs
  2293.     push    es            ; saves es over C call
  2294.     call    sfloat C, di        ; convert destination op to flonum
  2295.     pop    es
  2296.     sub    si, 2            ; back up the location pointer
  2297.     xor    bx, bx
  2298.     jmp    divi            ; re-execute div immed in floating point
  2299. @@ool:
  2300.     mov    dx, DIV_OP
  2301.     jmp    bini_ool
  2302. ENDP    divi
  2303.  
  2304. ;************************************************************************
  2305. ;* Test for (null? obj)                NULL?    reg        *
  2306. ;************************************************************************
  2307. PROC    null_p
  2308.     get1op
  2309.     mov    bx, ax
  2310.     cmp    [regs+bx.bpage], 0
  2311.     je    @@null
  2312.     xor    ax, ax            ; set register to nil (test false)
  2313.     mov    [regs+bx.bpage], al
  2314.     mov    [regs+bx.disp], ax
  2315.     jmp    next
  2316. @@null:
  2317.     mov    [regs+bx.bpage], T_PAGE*2
  2318.     mov    [regs+bx.disp], T_DISP
  2319.     jmp    next
  2320. ENDP    null_p
  2321.  
  2322. ;************************************************************************
  2323. ;*                            al   ah        *
  2324. ;* Test for eq? (pointers identical)        EQ?    dest,src    *
  2325. ;************************************************************************
  2326. PROC    eq_p
  2327.     get2op
  2328.     mov    bl, al            ; copy destination register number
  2329.     mov    di, bx
  2330.     mov    bl, ah            ; copy source register number
  2331.     mov    ax, [regs+bx.disp]    ; load page number of source operand
  2332.     cmp    ax, [regs+di.disp]    ; are the displacements identical?
  2333.     jne    @@noteq
  2334.     mov    al, [regs+bx.bpage]    ; load src operand's page number
  2335.     cmp    al, [regs+di.bpage]    ; are page numbers identical?
  2336.     jne    @@noteq
  2337.     mov    [regs+di.bpage], T_PAGE*2
  2338.     mov    [regs+di.disp], T_DISP
  2339.     jmp    next
  2340. @@noteq:
  2341.     xor    ax, ax
  2342.     mov    [regs+di.bpage], al
  2343.     mov    [regs+di.disp], ax
  2344.     jmp    next
  2345. ENDP    eq_p
  2346.  
  2347. ;************************************************************************
  2348. ;*                                al   ah    *
  2349. ;* Test for eqv? (pointers identical, or numbers equal) EQ?    dest,src*
  2350. ;************************************************************************
  2351. PROC    eqv_p
  2352.     get2op
  2353.     mov    bl, al            ; copy destination register in di
  2354.     mov    di, bx
  2355.     mov    bl, ah            ; copy source register number
  2356.     mov    ax, [regs+bx.disp]
  2357.     cmp    ax, [regs+di.disp]    ; are the displacements identical?
  2358.     jne    @@ptrnoteq
  2359.     mov    al, [regs+bx.bpage]
  2360.     cmp    al, [regs+di.bpage]    ; are page numbers identical?
  2361.     jne    @@ptrnoteq
  2362.     mov    [regs+di.bpage], T_PAGE*2
  2363.     mov    [regs+di.disp], T_DISP
  2364.     jmp    next
  2365. @@ptrnoteq:
  2366.     mov    ah, bl            ; copy source register number and load
  2367.     mov    bl, [regs+bx.bpage]    ; page number from source reg
  2368.     test    [attrib+bx], FIXNUMS or BIGNUMS or FLONUMS
  2369.     jz    @@string
  2370.     mov    ax, di            ; copy destination register number and load
  2371.     mov    bl, [regs+di.bpage]    ; page number from dest reg
  2372.     test    [attrib+bx], FIXNUMS or BIGNUMS or FLONUMS
  2373.     jz    @@string
  2374.     sub    si, 2            ; else set ip back to operands
  2375.     jmp    eq_n            ; and go test with "="
  2376. @@string:
  2377.     test    [attrib+bx], STRINGS
  2378.     jz    @@fail
  2379.     add    di, OFFSET regs
  2380.     jmp    in_equal_p        ; test using "equal?"
  2381. @@fail:
  2382.     xor    ax, ax
  2383.     mov    [regs+di.bpage], al
  2384.     mov    [regs+di.disp], ax
  2385.     jmp    next
  2386. ENDP    eqv_p
  2387.  
  2388. ;************************************************************************
  2389. ;*                                al   ah *
  2390. ;* Test equality of s-expressions            equal?    dest,src*
  2391. ;*                                    *
  2392. ;* Purpose:    Scheme interpreter support for the testing of "equality"*
  2393. ;*        of two s-expressions.                    *
  2394. ;************************************************************************
  2395. PROC    equal_p
  2396.     get2op
  2397.     mov    bl, al            ; copy destination register number
  2398.     lea    di, [regs+bx]        ; and load its address
  2399. in_equal_p:
  2400.     save    <si>
  2401.     mov    bl, ah            ; copy source register number
  2402.     add    bx, OFFSET regs
  2403.     call    sequal_p C, di, bx    ; call: sequal(&dest,&src)
  2404.     or    ax, ax            ; are operands equal? (return code not zero)
  2405.     je    @@fail
  2406.     mov    [(REG di).bpage], T_PAGE*2
  2407.     mov    [(REG di).disp], T_DISP
  2408.     jmp    next_pc
  2409. @@fail:
  2410.     mov    [(REG di).bpage], al
  2411.     mov    [(REG di).disp], ax
  2412.     jmp    next_pc
  2413. ENDP    equal_p
  2414.  
  2415. ;************************************************************************
  2416. ;*    Test for (atom? obj)                        *
  2417. ;************************************************************************
  2418. PROC    atom_p
  2419.     mov    dx, ATOM
  2420.     jmp    in_list
  2421. ENDP    atom_p
  2422.  
  2423. ;************************************************************************
  2424. ;*    Test for (char? obj)                        *
  2425. ;************************************************************************
  2426. PROC    char_p
  2427.     mov    dx, CHARS
  2428.     jmp    in_list
  2429. ENDP    char_p
  2430.  
  2431. ;************************************************************************
  2432. ;*    Test for (closure? obj)                        *
  2433. ;************************************************************************
  2434. PROC    closur_p
  2435.     mov    dx, CLOSURE
  2436.     jmp    in_list
  2437. ENDP    closur_p
  2438.  
  2439. ;************************************************************************
  2440. ;*    Test for (code? obj)                        *
  2441. ;************************************************************************
  2442. PROC    code_p
  2443.     mov    dx, CODE
  2444.     jmp    in_list
  2445. ENDP    code_p
  2446.  
  2447. ;************************************************************************
  2448. ;*    Test for (continuation? obj)                    *
  2449. ;************************************************************************
  2450. PROC    contin_p
  2451.     mov    dx, CONTINU
  2452.     jmp    in_list
  2453. ENDP    contin_p
  2454.  
  2455. ;************************************************************************
  2456. ;*    Test for (float? obj)                        *
  2457. ;************************************************************************
  2458. PROC    float_p
  2459.     mov    dx, FLONUMS
  2460.     jmp    in_list
  2461. ENDP    float_p
  2462.  
  2463. ;************************************************************************
  2464. ;*    Test for (integer? obj)                        *
  2465. ;************************************************************************
  2466. PROC    integr_p
  2467.     mov    dx, FIXNUMS or BIGNUMS
  2468.     jmp    in_list
  2469. ENDP    integr_p
  2470.  
  2471. ;************************************************************************
  2472. ;*    Test for (number? obj)                        *
  2473. ;************************************************************************
  2474. PROC    number_p
  2475.     mov    dx, NUMBERS
  2476.     jmp    in_list
  2477. ENDP    number_p
  2478.  
  2479. ;************************************************************************
  2480. ;*    Test for (pair? obj)                        *
  2481. ;************************************************************************
  2482. PROC    pair_p
  2483.     mov    dx, LISTCELL
  2484. in_list:
  2485.     get1op
  2486.     mov    bx, ax            ; copy register number
  2487.     mov    di, [regs+bx.page]    ; load page number and
  2488. attr_test:
  2489.     mov    ax, [attrib+di]
  2490.     and    ax, dx            ; test against mask
  2491.     jnz    attr_true
  2492. attr_false:
  2493.     mov    [regs+bx.page], 0    ; return ()
  2494.     mov    [regs+bx.disp], 0
  2495.     jmp    next
  2496. attr_true:
  2497.     mov    [regs+bx.bpage], T_PAGE*2
  2498.     mov    [regs+bx.disp], T_DISP
  2499.     jmp    next
  2500. ENDP    pair_p
  2501.  
  2502. ;************************************************************************
  2503. ;*    Test for (port? obj)                        *
  2504. ;************************************************************************
  2505. PROC    port_p
  2506.     mov    dx, PORTS
  2507.     get1op
  2508.     mov    bx, ax
  2509.     mov    di, [regs+bx.page]
  2510.     cmp    di, [console_reg.page]    ; is it same page as 'console?
  2511.     jne    attr_test
  2512.     mov    ax, [regs+bx.disp]
  2513.     cmp    ax, [console_reg.disp]
  2514.     je    attr_true
  2515.     jmp    attr_false
  2516. ENDP    port_p
  2517.  
  2518. ;************************************************************************
  2519. ;*    Test for (proc? obj)                        *
  2520. ;************************************************************************
  2521. PROC    proc_p
  2522.     mov    dx, CONTINU or CLOSURE
  2523.     jmp    in_list
  2524. ENDP    proc_p
  2525.  
  2526. ;************************************************************************
  2527. ;*    Test for (inline? obj)                        *
  2528. ;************************************************************************
  2529. PROC    inline_p
  2530.     mov    dx, I86CODE
  2531.     jmp    in_list
  2532. ENDP    inline_p
  2533.  
  2534. ;************************************************************************
  2535. ;*    Test for (string? obj)                        *
  2536. ;************************************************************************
  2537. PROC    string_p
  2538.     mov    dx, STRINGS
  2539.     jmp    in_list
  2540. ENDP    string_p
  2541.  
  2542. ;************************************************************************
  2543. ;*    Test for (symbol? obj)                        *
  2544. ;************************************************************************
  2545. PROC    symbol_p
  2546.     mov    dx, SYMBOLS
  2547.     jmp    in_list
  2548. ENDP    symbol_p
  2549.  
  2550. ;************************************************************************
  2551. ;*    Test for (vector? obj)                        *
  2552. ;************************************************************************
  2553. PROC    vector_p
  2554.     mov    dx, VECTORS
  2555.     jmp    in_list
  2556. ENDP    vector_p
  2557.  
  2558. ;************************************************************************
  2559. ;* is an integer even?                    even?    dest    *
  2560. ;*                                    *
  2561. ;* Purpose:    Scheme interpreter support for the even? predicate.    *
  2562. ;************************************************************************
  2563. PROC    even_p
  2564.     lea    dx, [@@msg]
  2565. DATASEG
  2566. @@msg    DB    "EVEN?", 0
  2567. CODESEG
  2568.     call    eo_which        ; is value even or odd?
  2569.     jnz    in_odd_p
  2570. in_even_p:
  2571.     mov    [(REG bx).bpage], T_PAGE*2
  2572.     mov    [(REG bx).disp], T_DISP
  2573.     save    <si>
  2574.     jmp    next_pc            ; reload es, as we loadpage'd
  2575. ENDP    even_p
  2576.  
  2577. ;************************************************************************
  2578. ;* is an integer odd?                    odd?    dest    *
  2579. ;*                                    *
  2580. ;* Purpose:    Scheme interpreter support for the odd? predicate.    *
  2581. ;************************************************************************
  2582. PROC    odd_p
  2583.     lea    dx, [@@msg]
  2584. DATASEG
  2585. @@msg    DB    "ODD?", 0
  2586. CODESEG
  2587.     call    eo_which        ; is value even or odd?
  2588.     jnz    in_even_p
  2589. in_odd_p:
  2590.     xor    ax, ax
  2591.     mov    [(REG bx).bpage], al
  2592.     mov    [(REG bx).disp], ax
  2593.     save    <si>
  2594.     jmp    next_pc            ; reload es, as we loadpage'd
  2595. ENDP    odd_p
  2596.  
  2597. JEQ_OPCODE =    01110100b
  2598. JNE_OPCODE =    01110101b
  2599. JLT_OPCODE =    01111100b
  2600. JGE_OPCODE =    01111101b
  2601. JLE_OPCODE =    01111110b
  2602. JGT_OPCODE =    01111111b
  2603.  
  2604. ;************************************************************************
  2605. ;*    Test for numeric inequality (!= n1 n2)                *
  2606. ;************************************************************************
  2607. PROC    ne_p
  2608.     mov    dx, NE_OP
  2609.     mov    [cs:cond_jmp], JNE_OPCODE
  2610.     jmp    cond_go
  2611. ENDP    ne_p
  2612.  
  2613. ;************************************************************************
  2614. ;*    Test for numeric less than (< n1 n2)                *
  2615. ;************************************************************************
  2616. PROC    lt_p
  2617.     mov    dx, LT_OP
  2618.     mov    [cs:cond_jmp], JLT_OPCODE
  2619.     jmp    cond_go
  2620. ENDP    lt_p
  2621.  
  2622. ;************************************************************************
  2623. ;*    Test for numeric greater than (> n1 n2)                *
  2624. ;************************************************************************
  2625. PROC    gt_p
  2626.     mov    dx, GT_OP
  2627.     mov    [cs:cond_jmp], JGT_OPCODE
  2628.     jmp    cond_go
  2629. ENDP    gt_p
  2630.  
  2631. ;************************************************************************
  2632. ;*    Test for numeric less than or equal (<= n1 n2)            *
  2633. ;************************************************************************
  2634. PROC    le_p
  2635.     mov    dx, LE_OP
  2636.     mov    [cs:cond_jmp], JLE_OPCODE
  2637.     jmp    cond_go
  2638. ENDP    le_p
  2639.  
  2640. ;************************************************************************
  2641. ;*    Test for numeric greater than or equal (>= n1 n2)        *
  2642. ;************************************************************************
  2643. PROC    ge_p
  2644.     mov    dx, GE_OP
  2645.     mov    [cs:cond_jmp], JGE_OPCODE
  2646.     jmp    cond_go
  2647. ENDP    ge_p
  2648.  
  2649. ;************************************************************************
  2650. ;*    Test for numeric equality    (= n1 n2)            *
  2651. ;************************************************************************
  2652. PROC    eq_n
  2653.     mov    dx, EQ_OP
  2654.     mov    [cs:cond_jmp], JEQ_OPCODE
  2655.     jmp    cond_go
  2656. ENDP    eq_n
  2657.  
  2658. ;************************************************************************
  2659. ;* Global definition - Support for arithmetic testing    (cond n1 n2)    *
  2660. ;************************************************************************
  2661. PROC    cond_go
  2662.     get2op
  2663.     mov    bl, al            ; copy n1 register number
  2664.     lea    di, [regs+bx]
  2665.     mov    bl, ah            ; copy n2 register number
  2666.     add    bx, OFFSET regs
  2667.     cmp    [(REG di).bpage], SPECFIX*2
  2668.     jne    @@ool
  2669.     cmp    [(REG bx).bpage], SPECFIX*2
  2670.     jne    @@ool
  2671.     mov    ax, [(REG bx).disp]
  2672.     cmp    [(REG di).disp], ax
  2673. LABEL    cond_jmp    BYTE
  2674.     jmp    SHORT    @@true
  2675. @@false:
  2676.     xor    ax, ax
  2677.     mov    [(REG di).bpage], al
  2678.     mov    [(REG di).disp], ax
  2679.     jmp    next
  2680. @@true:
  2681.     mov    [(REG di).bpage], T_PAGE*2
  2682.     mov    [(REG di).disp], T_DISP
  2683.     jmp    next
  2684.  
  2685. @@ool:
  2686.     push    es            ; saves es over C call
  2687.     call    arith2 C, dx, di, bx    ; Call the arithmetic processor
  2688.     pop    es
  2689.     or    ax, ax            ; test result returned from arith2
  2690.     jg    @@true
  2691.     jz    @@false
  2692.     jmp    sch_err
  2693. ENDP    cond_go
  2694.  
  2695. ;************************************************************************
  2696. ;    Test for equality to zero (zero? n)                *
  2697. ;************************************************************************
  2698. PROC    eq_z_p
  2699.     mov    dx, ZERO_OP
  2700.     mov    [cs:cond0_jmp], JEQ_OPCODE
  2701.     jmp    cond0_go
  2702. ENDP    eq_z_p
  2703.  
  2704. ;************************************************************************
  2705. ;*    Test for less than zero (negative? n)                *
  2706. ;************************************************************************
  2707. PROC    lt_z_p
  2708.     mov    dx, NEG_OP
  2709.     mov    [cs:cond0_jmp], JLT_OPCODE
  2710.     jmp    cond0_go
  2711. ENDP    lt_z_p
  2712.  
  2713. ;************************************************************************
  2714. ;*    Test for greater than zero (positive? n)            *
  2715. ;************************************************************************
  2716. PROC    gt_z_p
  2717.     mov    dx, POS_OP
  2718.     mov    [cs:cond0_jmp], JGT_OPCODE
  2719.     jmp    cond0_go
  2720. ENDP    gt_z_p
  2721.  
  2722. ;************************************************************************
  2723. ;* Global definition - Support for arithmetic testing (cond:0 n)    *
  2724. ;************************************************************************
  2725. PROC    cond0_go
  2726.     get1op
  2727.     mov    bx, ax
  2728.     add    bx, OFFSET regs
  2729.     cmp    [(REG bx).bpage], SPECFIX*2
  2730.     jne    @@ool
  2731.     cmp    [(REG bx).disp], 0
  2732. LABEL    cond0_jmp    BYTE
  2733.     jmp    SHORT @@true
  2734. @@false:
  2735.     xor    ax, ax
  2736.     mov    [(REG bx).bpage], al
  2737.     mov    [(REG bx).disp], ax
  2738.     jmp    next
  2739. @@true:
  2740.     mov    [(REG bx).bpage], T_PAGE*2
  2741.     mov    [(REG bx).disp], T_DISP
  2742.     jmp    next
  2743.  
  2744. @@ool:
  2745.     push    bx es            ; saves es over C call
  2746.     call    arith1 C, dx, bx
  2747.     pop    es bx
  2748.     or    ax, ax
  2749.     jg    @@true
  2750.     jz    @@false
  2751.     jmp    sch_err
  2752. ENDP    cond0_go
  2753.  
  2754. ;************************************************************************
  2755. ;* (ascii->char n)                    ascii->char dest*
  2756. ;*                                    *
  2757. ;* Purpose:    Scheme interpreter support for the ascii->char function.*
  2758. ;************************************************************************
  2759. PROC    asc_char
  2760.     get1op
  2761.     xchg    ax, bx
  2762.     lea    di, [regs+bx]
  2763.     cmp    [(REG di).bpage], SPECFIX*2
  2764.     jne    @@error
  2765.     and    [(REG di).disp], 00ffh
  2766.     mov    [(REG di).bpage], SPECCHAR*2 ; convert to character
  2767.     jmp    next
  2768. @@error:
  2769.     lea    bx, [@@msg]
  2770. DATASEG
  2771. @@msg    DB    "INTEGER->CHAR", 0
  2772. CODESEG
  2773.     jmp    char_error
  2774. ENDP    asc_char
  2775.  
  2776. ;************************************************************************
  2777. ;* (char->ascii n)                    char->ascii dest*
  2778. ;*                                    *
  2779. ;* Purpose:    Scheme interpreter support for the char->ascii function.*
  2780. ;************************************************************************
  2781. PROC    char_asc
  2782.     get1op
  2783.     xchg    ax, bx
  2784.     lea    di, [regs+bx]
  2785.     cmp    [(REG di).bpage], SPECCHAR*2
  2786.     jne    @@error
  2787.     mov    [(REG di).bpage], SPECFIX*2
  2788.     jmp    next
  2789. @@error:
  2790.     lea    bx, [@@msg]
  2791. DATASEG
  2792. @@msg    DB    "CHAR->INTEGER", 0
  2793. CODESEG
  2794. char_error:
  2795.     mov    ax, 1
  2796.     call    set_src_error C, bx, ax, di
  2797.     jmp    sch_err
  2798. ENDP    char_asc
  2799.  
  2800. ;************************************************************************
  2801. ;*    Support for list length    (length list)                *
  2802. ;************************************************************************
  2803. PROC    slength
  2804.     get1op
  2805.     mov    bx, ax
  2806.     save    <si>            ; save the program counter
  2807.     lea    di, [regs+bx]        ; load the address of the dest reg
  2808.     mov    bx, [(REG di).page]
  2809.     mov    si, [(REG di).disp]
  2810.     xor    ax, ax            ; zero the counter (32-bits)
  2811.     cwd
  2812. @@loop:
  2813.     cmp    bl, NIL_PAGE*2        ; pointer to nil?
  2814.     je    @@done
  2815.     cmp    [ptype+bx], LISTTYPE
  2816.     je    @@typeok
  2817.  
  2818.     lea    bx, [@@msg]
  2819. DATASEG
  2820. @@msg    DB    "LENGTH", 0
  2821. CODESEG
  2822.     mov    ax, 1
  2823.     call    set_src_error C, bx, ax, di
  2824.     jmp    sch_err
  2825. @@typeok:
  2826.     add    ax, 1            ; increment list cell count
  2827.     adc    dx, 0
  2828.     ldpage    es, bx
  2829.     mov    bl, [(LISTDEF es:si).cdr.page]
  2830.     mov    si, [(LISTDEF es:si).cdr.disp]
  2831.     cmp    [s_break], 0        ; has the shift-break key been depressed?
  2832.     je    @@loop
  2833. in_slength:
  2834.     mov    ax, 2            ; load instruction length = 2
  2835.     call    restart C, ax        ; link to Scheme debugger
  2836. @@done:
  2837.     call    long2int C, di, ax, dx
  2838.     jmp    next_pc
  2839. ENDP    slength
  2840.  
  2841. ;************************************************************************
  2842. ;*    Support for Last-pair    (last-pair list)            *
  2843. ;************************************************************************
  2844. PROC    lst_pair
  2845.     get1op
  2846.     save    <si>
  2847.     mov    di, ax
  2848.     mov    bx, [regs+di.page]
  2849.     cmp    bl, NIL_PAGE*2        ; null pointer?
  2850.     je    @@exit
  2851.     cmp    [ptype+bx], LISTTYPE
  2852.     jne    @@exit
  2853.     mov    si, [regs+di.disp]
  2854.     xor    dx, dx
  2855. @@loop:
  2856.     ldpage    es, bx
  2857.     mov    dl, [(LISTDEF es:si).cdr.page]
  2858.     cmp    dl, NIL_PAGE*2
  2859.     je    @@done
  2860.     mov    di, dx            ; copy cdr's page number
  2861.     cmp    [ptype+di], LISTTYPE
  2862.     jne    @@done
  2863.     mov    bl, dl            ; follow linked list
  2864.     mov    si, [(LISTDEF es:si).cdr.disp]
  2865.     cmp    [s_break], 0        ; has the shift-break key been depressed?
  2866.     je    @@loop
  2867.     jmp    in_slength
  2868. @@done:
  2869.     mov    di, ax            ; re-load destination register number
  2870.     mov    [regs+di.bpage], bl
  2871.     mov    [regs+di.disp], si
  2872. @@exit:
  2873.     jmp    next_pc
  2874. ENDP    lst_pair
  2875.  
  2876. ;************************************************************************
  2877. ;* (reverse! list)                    reverse! dest    *
  2878. ;*                                    *
  2879. ;* Purpose:    Scheme interpreter support for the reverse! primitive    *
  2880. ;*                                    *
  2881. ;* Notes:    The following registers are used by this routine:    *
  2882. ;*        bl - page number of the current list cell        *
  2883. ;*        di - displacement of the current list cell        *
  2884. ;*        es - paragraph address of the current list cell        *
  2885. ;*            Note: es:[di] address the current list cell    *
  2886. ;*        dl - page number of the previous list cell        *
  2887. ;*        ax - displacement of the previous list cell        *
  2888. ;*        si - destination register number            *
  2889. ;************************************************************************
  2890. PROC    reverseb
  2891.     get1op
  2892.     save    <si>
  2893.     mov    bl, al
  2894.     lea    si, [regs+bx]
  2895.     mov    bl, [(REG si).bpage]
  2896.     mov    di, [(REG si).disp]
  2897.     cmp    [ptype+bx], LISTTYPE        ; first element has to be a pair
  2898.     jne    @@error
  2899.     push    bx di                ; save resulting last-pair
  2900.     xor    ax, ax
  2901.     xor    dx, dx
  2902. @@loop:
  2903.     cmp    bl, NIL_PAGE*2            ; end of list (current cell nil)?
  2904.     je    @@done
  2905.     ldpage    es, bx
  2906.     xchg    [(LISTDEF es:di).cdr.page], dl    ; swap cdr field with previous cell
  2907.     xchg    [(LISTDEF es:di).cdr.disp], ax    ;    pointer
  2908.     xchg    bx, dx                ; current cell <-> (cdr current cell)
  2909.     xchg    di, ax
  2910.     cmp    [ptype+bx], LISTTYPE        ; dotted list ?
  2911.     je    @@loop                ;
  2912.     mov    cx, di                ; special handling of dotted lists
  2913.     mov    dh, bl                ; used to implement LIST?
  2914.     pop    di bx                ;  (reverse! behavior is only specified
  2915.     ldpage    es, bx                ;  for proper lists)
  2916.     mov    [(LISTDEF es:di).cdr.page], dh    ; put cdr of dotted pair at
  2917.     mov    [(LISTDEF es:di).cdr.disp], cx    ; dotted end of reversed list
  2918.     push    bx di
  2919. @@done:
  2920.     pop    di bx
  2921.     mov    [(REG si).bpage], dl        ; make destination register point
  2922.     mov    [(REG si).disp], ax        ; to new head of (reversed) list
  2923.     jmp    next_pc
  2924. @@error:
  2925.     mov    [(REG si).bpage], dl
  2926.     mov    [(REG si).disp], ax
  2927.     lea    bx, [@@msg]
  2928. DATASEG
  2929. @@msg    DB    "REVERSE!", 0
  2930. CODESEG
  2931.     jmp    src_err
  2932. ENDP    reverseb
  2933.  
  2934. ;************************************************************************
  2935. ;*            Mouse support                    *
  2936. ;************************************************************************
  2937. PROC    smouse    NEAR
  2938.     or    [mouse_use], 1
  2939.     get1op
  2940.     mov    [save_ax], ax
  2941.     mov    cx, ax            ; used by @@pushint
  2942.     call    @@pushint
  2943.     mov    [save_bx], bx        ; save 1st register
  2944.     call    @@pushint
  2945.     call    @@pushint
  2946.     call    @@pushint
  2947.     pop    dx
  2948.     call    @@pushint
  2949.     call    @@pushint        ; stack contains DI, SI, CX, BX, AX
  2950.     cmp    [BYTE save_ax], 7
  2951.     jne    @@6args
  2952.     call    get1parm
  2953.     mov    bx, ax
  2954.     cmp    [(REG bx).bpage], NIL_PAGE*2
  2955.     jne    @@string
  2956.     push    cs
  2957.     pop    es
  2958.     lea    dx, [cs:mouse_handler]
  2959.     jmp    @@6args
  2960. @@string:
  2961.     mov    dx, [(REG bx).disp]
  2962.     mov    bx, [(REG bx).page]
  2963.     ldpage    es, bx
  2964.     add    dx, OFFSET (TYPE STRDEF).buffer
  2965. @@6args:
  2966.     pop    di
  2967.     pop    si
  2968.     pop    cx
  2969.     pop    bx
  2970.     pop    ax
  2971.     or    ax, ax
  2972.     jb    @@special
  2973.     int    33h
  2974. @@return:
  2975.     push    ax
  2976.     push    bx
  2977.     push    cx
  2978.     push    dx
  2979.     mov    [tmp_reg.bpage], SPECFIX*2
  2980.     mov    [save_cx], 4
  2981.     lea    bx, [nil_reg]
  2982. @@loop:
  2983.     pop    [tmp_reg.disp]
  2984.     call    cons C, [save_bx], [tmp_adr], bx
  2985.     mov    bx, [save_bx]
  2986.     dec    [save_cx]
  2987.     jnz    @@loop
  2988.     jmp    next_pc
  2989.  
  2990. @@special:
  2991.     mov    [mouse_use], bx        ; set first use flag
  2992.     jmp    @@return
  2993.  
  2994. @@pushint:
  2995.     pop    di            ; get return address
  2996.     jcxz    @@outofargs
  2997.     dec    cx
  2998.     call    get1parm
  2999.     mov    bx, ax
  3000.     push    [(REG bx).disp]
  3001.     jmp    di
  3002. @@outofargs:
  3003.     xor    ax, ax
  3004.     push    ax
  3005.     jmp    di
  3006. ENDP    smouse
  3007.  
  3008. ;************************************************************************
  3009. ;* Interface to Varargs        (%graphics/mouse/esc len arg1 ... argn)    *
  3010. ;*                                    *
  3011. ;* completely revised 930929 LB                        *
  3012. ;* completely revised 3/6/92 LB - modified 15/6/92 MV            *
  3013. ;* now len=n is the number of optional arguments,            *
  3014. ;* arg1 is the subfunction number                    *
  3015. ;* and arg2..argn have any type you wish                *
  3016. ;* arg1 will be used to hold the result                    *
  3017. ;************************************************************************
  3018. PROC    sgraph
  3019.     lea    bx, [@@msg]
  3020.     lea    di, [@@link]
  3021.     jmp    varargs
  3022. DATASEG
  3023. @@link    DD    graphit
  3024. @@msg    DB    "%GRAPHICS", 0
  3025. CODESEG
  3026. ENDP    sgraph
  3027.  
  3028. PROC    s_esc
  3029.     lea    bx, [@@msg]
  3030.     lea    di, [@@link]
  3031.     jmp    varargs
  3032. DATASEG
  3033. @@link    DD    asm_link
  3034. @@msg    DB    "%ESC", 0
  3035. CODESEG
  3036. ENDP    s_esc
  3037.  
  3038. PROC    varargs
  3039.     push    bx            ; save message's address
  3040.     get1op
  3041.     mov    cx, ax
  3042.     mov    bx, ax
  3043. @@loop:
  3044.     get1op
  3045.     mov    ah, 0
  3046.     add    ax, OFFSET regs
  3047.     push    ax
  3048.     loop    @@loop
  3049.     save    <si>
  3050.     push    bx            ; pass number of args to routine
  3051.     call    [DWORD di] C
  3052.     pop    bx            ; graphit SHOULD NOT modify arg count
  3053.     shl    bx, 1
  3054.     add    sp, bx
  3055.     pop    bx            ; restore message
  3056.     or    ax, ax
  3057.     jnz    @@error
  3058.     jmp    next_pc
  3059. @@error:
  3060.     jmp    src_err
  3061. ENDP    varargs
  3062.  
  3063. ;************************************************************************
  3064. ;*                Error routines                *
  3065. ;************************************************************************
  3066.  
  3067. ;************************************************************************
  3068. ;*                Timer Ran Down                *
  3069. ;************************************************************************
  3070. ;    Note:    the "reset_timer" variable must be in the code segment 'cause
  3071. ;        there's no telling where the ds register points when a
  3072. ;        timer interrupt occurs.
  3073.  
  3074. reset_timer DW    0            ; save area for resetting a timer int
  3075. PROC    timeout
  3076.     mov    ax, [cs:reset_timer]
  3077.     mov    [cs:$$sm$entry], ax    ; branch at top of vm loop
  3078.     call    rsttimer C        ; turn off the timer support
  3079.     mov    bx, TIMEOUT_CONDITION    ; load "timeout" error code
  3080. in_timer_restart:
  3081.     xor    ax, ax            ; set code for "restartable" operation
  3082.     lea    cx, [nil_reg]        ; set *irritant* to 'nil
  3083. in_timer_setnumerr:
  3084.     push    es            ; saves es over C call
  3085.     call    set_numeric_error C, ax, bx, cx
  3086.     pop    es
  3087.     jmp    sch_err
  3088. ENDP    timeout
  3089.  
  3090. ;************************************************************************
  3091. ;*    Mouse Event occured                        *
  3092. ;************************************************************************
  3093. reset_mouse DW    0
  3094. PROC    mouseevent
  3095.     push    si            ; we must keep the VM IP counter
  3096.     mov    ax, [cs:reset_mouse]
  3097.     mov    [cs:$$sm$entry], ax    ; branch at top of vm loop
  3098.     lea    si, [mstate]
  3099.     lea    cx, [nil_reg]        ; set *irritant* to 'mouse params'
  3100. @@loop:
  3101.     call    mputevent C
  3102.     call    cons C, [tmp_adr], [tm2_adr], cx
  3103.     lea    cx, [tmp_reg]
  3104.     add    si, SIZE MOUSESTATE
  3105.     cmp    si, [mstptr]
  3106.     jb    @@loop
  3107.     mov    [mstptr], OFFSET mstate
  3108.  
  3109.     mov    bx, TIMEOUT_CONDITION    ; load "mouse" error code
  3110.     xor    ax, ax            ; set code for "restartable" operation
  3111.     pop    si
  3112.     jmp    in_timer_setnumerr
  3113.  
  3114. PROC    mputevent C
  3115.     LOCAL    @@reg:REG, @@ptr:WORD
  3116.     lea    ax, [@@reg]
  3117.     mov    [@@ptr], ax
  3118.     call    long2int C, ax, [WORD LOW (MOUSESTATE si).time], [WORD HIGH (MOUSESTATE si).time]
  3119.     lea    ax, [nil_reg]
  3120.     call    cons C, [tm2_adr], [@@ptr], ax
  3121.     lea    di, [(MOUSESTATE si).y_mickeys]    ; last arg
  3122.     mov    [@@reg.bpage], SPECFIX*2    ; and enqueue the event
  3123. @@args:
  3124.     mov    ax, [di]
  3125.     mov    [@@reg.disp], ax
  3126.     call    cons C, [tm2_adr], [@@ptr], [tm2_adr]
  3127.     dec    di
  3128.     dec    di
  3129.     cmp    di, si
  3130.     jae    @@args
  3131.     ret
  3132. ENDP
  3133. ENDP    mouseevent
  3134.  
  3135. ;************************************************************************
  3136. ;*            Shift-Break Interrupt                *
  3137. ;************************************************************************
  3138. PROC    sc_debug
  3139.     mov    ax, [cs:reset_sb]    ; reset forced branch at top of VM loop
  3140.     mov    [cs:$$sm$entry], ax
  3141.     mov    [s_break], 0        ; reset shift-break flag
  3142.     mov    bx, SHIFT_BREAK_CONDITION ; load "shift-break" error code
  3143.     jmp    in_timer_restart
  3144. ENDP    sc_debug
  3145.  
  3146. ;************************************************************************
  3147. ;*            Recover stack macro                *
  3148. ;************************************************************************
  3149. MACRO    CLEANUP_STACK
  3150.     push    ax bx cx dx es        ; preserve main registers
  3151.     mov    ax, [reset_bp]        ; compute new stack limits
  3152.     sub    ax, LCLSIZE+USESSIZE
  3153.     call    @REG@cleanup$qp3REGt1 C, sp, ax
  3154.     pop    es dx cx bx ax
  3155.     mov    bp, [reset_bp]        ; clean up stack
  3156.     lea    sp, [bp-LCLSIZE-USESSIZE]
  3157. ENDM
  3158.  
  3159. ;************************************************************************
  3160. ;*            DOS fatal I/O error process            *
  3161. ;************************************************************************
  3162. PROC    dos_error FAR
  3163.     add    sp, 4            ; dump return address
  3164.     pop    ax            ; restart/non-restart flag
  3165.     pop    bx            ; error code
  3166.     pop    cx            ; *irritant*
  3167.     CLEANUP_STACK
  3168.     jmp    in_timer_setnumerr    ; go invoke Scheme debugger
  3169. ENDP    dos_error
  3170.  
  3171. ;************************************************************************
  3172. ;*            Error-- Undefined Opcode            *
  3173. ;************************************************************************
  3174. PROC    not_op
  3175.     dec    si            ; back up location pointer
  3176.     save    <si>            ;    and save it
  3177.     lea    bx, [@@msg]
  3178.     mov    [tmp_reg.bpage], SPECFIX*2; convert opcode to a fixnum
  3179.     mov    [tmp_reg.disp], ax    ;    representation for use as "irritant"
  3180.     lea    ax, [tmp_reg]
  3181.     jmp    in_recompil_error
  3182. DATASEG
  3183. @@msg    DB    "[VM INTERNAL ERROR] Undefined opcode", LF, 0
  3184. CODESEG
  3185. ENDP    not_op
  3186.  
  3187. ;************************************************************************
  3188. ;*            Error-- Invalid Source Operand            *
  3189. ;************************************************************************
  3190. ;    Note:    at this point, bx contains the address for text of failing inst.
  3191. PROC    src_err
  3192.     xor    ax, ax
  3193.     call    set_src_error C, bx, ax
  3194.     jmp    sch_err        ; link to Scheme debugger
  3195. ENDP
  3196.  
  3197. ;************************************************************************
  3198. ;*    Error-- Object Module Not Compatible With Current Revision Level    *
  3199. ;************************************************************************
  3200. PROC    recompil
  3201.     lea    ax, [nil_reg]
  3202.     lea    bx, [@@msg]
  3203. in_recompil_error:
  3204.     mov    cx, 1
  3205.     call    set_error C, cx, bx, ax    ; set the error parameters
  3206.     jmp    sch_err        ; link to Scheme debugger
  3207. DATASEG
  3208. @@msg    DB    "[VM ERROR encountered!] Object module incompatible with this Version", LF
  3209.     DB    "Recompile from Source", LF, 0
  3210. CODESEG
  3211. ENDP    recompil
  3212.  
  3213. ;************************************************************************
  3214. ;*        Error: Feature Not Yet Implemented            *
  3215. ;************************************************************************
  3216. PROC    not_yet
  3217.     lea    bx, [@@msg]
  3218.     dec    si            ; back up location pointer
  3219.     push    es            ; saves es over C call
  3220.     call    zprintf C, bx        ; call zprintf
  3221.     pop    es
  3222.     mov    ax, RV_CLOBBERED
  3223.     jmp    in_debug
  3224. DATASEG
  3225. @@msg    DB    "[VM INTERNAL ERROR] Feature not implemented", LF, 0
  3226. CODESEG
  3227. ENDP    not_yet
  3228.  
  3229. ;************************************************************************
  3230. ;*            Force Restart of Current Operation        *
  3231. ;************************************************************************
  3232. PROC C    restart FAR @@inlength:WORD
  3233.     mov    ax, [@@inlength]
  3234.     CLEANUP_STACK
  3235.     sub    [save_si], ax        ; back up the instruction pointer
  3236.     jmp    next_pc
  3237. ENDP    restart
  3238.  
  3239. ;************************************************************************
  3240. ;*            Go to error handling code from C        *
  3241. ;************************************************************************
  3242. PROC C    scheme_error FAR
  3243.     CLEANUP_STACK
  3244. ;    jmp    sch_err            ; fall through
  3245. ENDP    scheme_error
  3246.  
  3247. ;************************************************************************
  3248. ;*            Link to the Scheme Debugger            *
  3249. ;************************************************************************
  3250. PROC    sch_err
  3251.     call    force_call C, si    ; force a new stack frame to be built
  3252.     mov    bx, SPECCODE*2        ; load code base pointer for debug init
  3253.     mov    [cb_reg.bpage], bl
  3254.     mov    [cb_reg.disp], 0
  3255.     ldpage    es, bx
  3256.     mov    si, [err_ent]        ; load error entry point offset
  3257.     cld
  3258.     jmp    next
  3259. ENDP    sch_err
  3260.  
  3261. ;************************************************************************
  3262. ;* Scheme-Reset/Reset                            *
  3263. ;*                                    *
  3264. ;* Purpose:    To re-initialize the VM's environment to correct for    *
  3265. ;*        some error condition                    *
  3266. ;************************************************************************
  3267. PROC    force_reset FAR
  3268.     CLEANUP_STACK
  3269. ;    jmp    s_reset            ; falls through
  3270. ENDP    force_reset
  3271.  
  3272. PROC    s_reset
  3273.     push    es            ; saves es over C call
  3274.     call    scheme_reset C        ; Adjust fluid environment
  3275.     pop    es
  3276. ;    jmp    reset            ; falls through
  3277. ENDP    s_reset
  3278.  
  3279. PROC    reset
  3280.     push    es            ; saves es over C call
  3281.     call    reset_fasl C        ; reset %fasl input data structures
  3282.     pop    es
  3283.     xor    ax, ax            ; create a value of zero/nil
  3284.     mov    [prev_reg.page], ax    ; previous stack segment <- nil
  3285.     mov    [prev_reg.disp], ax
  3286.     mov    [cb_reg.disp], ax    ; current code base <- loader's code page
  3287.     mov    [cb_reg.page], SPECCODE*2
  3288.     mov    [base], ax        ; reset stack
  3289.     mov    [frameptr], ax
  3290.     mov    [topofstack], SIZE STKFDEF-SIZE POINTER
  3291.     mov    bx, SPECCODE*2        ; set the location pointer and code paragraph address
  3292.     ldpage    es, bx
  3293.     mov    si, [rst_ent]        ; load the new location pointer
  3294. ;    jmp    clr_regs        ; falls through
  3295. ENDP    reset
  3296.  
  3297. ;************************************************************************
  3298. ;* Clear VM registers                    clear-regs    *
  3299. ;************************************************************************
  3300. PROC    clr_regs
  3301.     push    es
  3302.     push    ds            ; make es point to ds
  3303.     pop    es
  3304.     xor    ax, ax
  3305.     mov    [tmp_reg.disp], ax    ; clear the VM's temporary register, too
  3306.     mov    [tmp_reg.page], ax
  3307.     mov    [tm2_reg.disp], ax    ; clear the VM's temporary register, too
  3308.     mov    [tm2_reg.page], ax
  3309.     lea    di, [regs]        ; store #!false into R0 and R1
  3310.     mov    cx, 4
  3311.     rep    stosw
  3312.  
  3313.     mov    bx, UN_DISP        ; load pointer for "unbound" symbol
  3314.     mov    dx, UN_PAGE*2
  3315.     mov    cx, NUM_REGS-2        ; load iteration count
  3316. @@loop:
  3317.     mov    ax, bx            ; copy '**unbound** displacement pointer
  3318.     stosw
  3319.     mov    ax, dx            ; do likewise for the page number component
  3320.     stosw
  3321.     loop    @@loop
  3322.  
  3323.     pop    es
  3324.     jmp    next
  3325. ENDP    clr_regs
  3326.  
  3327. ;************************************************************************
  3328. ;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3)    *
  3329. ;************************************************************************
  3330. PROC    s_append
  3331.     mov    cx, 7            ; load count of number of operands
  3332. @@pushargs:
  3333.     xor    ax, ax            ; clear ah
  3334.     get1op
  3335.     add    ax, OFFSET regs    ; compute the register's address
  3336.     push    ax            ; save the register's address on the stack
  3337.     loop    @@pushargs
  3338.     save    <si>
  3339.     call    str_apnd C        ; FAR call to substring-append support
  3340.     or    ax, ax            ; success ?
  3341.     jnz    @@error
  3342.     add    sp, 2*7            ; if yes, pop off arguments from stack
  3343.     jmp    next_pc
  3344. @@error:
  3345.     lea    ax, [@@msg]        ; else send standard error message
  3346.     mov    cx, 7
  3347.     call    set_src_error C, ax, cx ; ADD these arguments to the 7 other
  3348.     add    sp, 2*7            ; pop off arguments
  3349. in_append_error:
  3350.     jmp    sch_err
  3351. DATASEG
  3352. @@msg    DB    "%STRING-APPEND", 0
  3353. CODESEG
  3354. ENDP    s_append
  3355.  
  3356. ;************************************************************************
  3357. ;* (%substring-display str start end row-displacement window)        *
  3358. ;************************************************************************
  3359. PROC    s_disply
  3360.     mov    cx, 5
  3361. @@pushargs:
  3362.     xor    ax, ax
  3363.     get1op
  3364.     add    ax, OFFSET regs
  3365.     push    ax
  3366.     loop    @@pushargs
  3367.     save    <si>
  3368.     call    str_disp C
  3369.     add    sp, 2*5
  3370.     or    ax, ax            ; did an error occur ?
  3371.     jnz    in_append_error
  3372.     jmp    next_pc
  3373. ENDP    s_disply
  3374.  
  3375. ;************************************************************************
  3376. ;* Invoke garbage collection                    gc    *
  3377. ;************************************************************************
  3378. PROC    gc
  3379.     save    <si>
  3380.     xor    ax, ax            ; assume CX = NILPAGE*2 = NILDISP
  3381.     mov    [tmp_reg.page], ax    ; clear tmp_reg.rreg prior to GC
  3382.     mov    [tmp_reg.disp], ax
  3383.     mov    [tm2_reg.page], ax    ; clear tm2_reg.rreg prior to GC
  3384.     mov    [tm2_reg.disp], ax
  3385.     call    garbage    C        ; call garbage collection driver
  3386.     jmp    next_pc
  3387. ENDP    gc
  3388.  
  3389. ;************************************************************************
  3390. ;* Invoke garbage collection with compaction            gc2    *
  3391. ;************************************************************************
  3392. PROC    sgc2
  3393.     save    <si>
  3394.     xor    ax, ax            ; assume CX = NILPAGE*2 = NILDISP
  3395.     mov    [tmp_reg.page], ax    ; clear tmp_reg.rreg prior to GC
  3396.     mov    [tmp_reg.disp], ax
  3397.     mov    [tm2_reg.page], ax    ; clear tm2_reg.rreg prior to GC
  3398.     mov    [tm2_reg.disp], ax
  3399.     call    garbage    C        ; call garbage collection driver
  3400.     call    gcsquish C
  3401.     jmp    next_pc
  3402. ENDP    sgc2
  3403.  
  3404. ;************************************************************************
  3405. ;* Begin Debug                            %begin-debug *
  3406. ;************************************************************************
  3407. PROC    debug_op
  3408.     mov    [vm_debug], 1        ; enable VM debugger for (%begin-debug)
  3409.     mov    ax, RV_SDEBUG
  3410. in_debug:
  3411. IFDEF    VMDEBUG
  3412.     mov    bx, [cs:$$sm$trace]    ; modify interpreter to enable instr.
  3413.     mov    [cs:$$sm$entry], bx
  3414.     mov    [s_break], 0        ; reset shift-break flag
  3415. ENDIF
  3416.     jmp    in_exit
  3417. ENDP    debug_op
  3418.  
  3419. ;************************************************************************
  3420. ;* Exit interpreter                            *
  3421. ;************************************************************************
  3422. PROC    exit_op
  3423.     get1op
  3424.     add    ax, OFFSET regs
  3425.     mov    bx, ax
  3426.     xor    ax, ax
  3427.     cmp    [(REG bx).bpage], SPECFIX*2
  3428.     jne    @@notfix
  3429.     mov    ax, [(REG bx).disp]
  3430. @@notfix:
  3431.     mov    bx, [$$retcode]
  3432.     mov    [bx], ax
  3433.     sub    si, 2            ; back up PC to avoid falling past end
  3434.     mov    ax, RV_HALT
  3435. in_exit:
  3436.     mov    bx, [$$entry]
  3437.     mov    [bx], si
  3438. ;    jmp    end_interp        ; fall through
  3439. ENDP    exit_op
  3440.  
  3441. end_interp:
  3442.     ret
  3443.  
  3444. ENDP    interp
  3445.     END
  3446.  
  3447.